! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2Kinds USE ISO_FORTRAN_ENV, ONLY: INT32 IMPLICIT NONE PUBLIC SAVE INTEGER, PARAMETER :: I4B = INT32 !SELECTED_INT_KIND(9) CONTAINS ! Subroutine used only to avoid compiler warnings about unused variables ! and set but not referenced variables. ELEMENTAL SUBROUTINE HS_REFERENCE(r) CLASS(*), INTENT(IN) :: r SELECT TYPE(v => r) CLASS DEFAULT RETURN END SELECT END SUBROUTINE HS_REFERENCE END MODULE HS2Kinds ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2String USE HS2Kinds IMPLICIT NONE PRIVATE PUBLIC :: HSString TYPE HSString CHARACTER(LEN=:), PRIVATE, ALLOCATABLE :: str INTEGER(I4B), PRIVATE :: LEN = 0 CONTAINS GENERIC :: ASSIGNMENT(=) => setHSString PROCEDURE, PASS :: setHSString GENERIC :: OPERATOR(+) => addh PROCEDURE, PRIVATE, PASS :: addh END TYPE HSString CONTAINS ELEMENTAL FUNCTION addh(this, c) RESULT(answ) CLASS(HSString), INTENT(IN) :: this CLASS(HSString), INTENT(IN) :: c TYPE(HSString) :: answ CALL HS_REFERENCE(c) answ = this RETURN END FUNCTION addh ELEMENTAL SUBROUTINE setHSString(this, from) CLASS(HSString), INTENT(INOUT) :: this CLASS(HSString), INTENT(IN) :: from this%str = from%str RETURN END SUBROUTINE setHSString END MODULE HS2String ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2Error USE HS2Kinds USE HS2String, ONLY: HSString IMPLICIT NONE PRIVATE PUBLIC :: HSError TYPE, EXTENDS(HSString) :: HSError END TYPE HSError END MODULE HS2Error ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2DateTime USE HS2Kinds IMPLICIT NONE PRIVATE SAVE PUBLIC :: HSTimeSpec PUBLIC :: HSDateTime TYPE HSTimeSpec INTEGER(I4B), PRIVATE :: val = 2 CONTAINS PROCEDURE, PASS :: toString => specToString END TYPE HSTimeSpec TYPE(HSTimeSpec), PARAMETER :: HSUTC = HSTimeSpec(0) TYPE HSDateTime TYPE(HSTimeSpec) :: spec = HSUTC END TYPE HSDateTime CONTAINS FUNCTION specToString(this) RESULT(answ) USE HS2String, ONLY: HSString CLASS(HSTimeSpec), INTENT(IN) :: this TYPE(HSString) :: answ CALL HS_REFERENCE(this) CALL HS_REFERENCE(answ) END FUNCTION specToString END MODULE HS2DateTime ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2Core USE HS2Kinds USE HS2Error, ONLY: HSError USE HS2String, ONLY: HSString USE HS2DateTime, ONLY: HSDateTime IMPLICIT NONE PRIVATE SAVE PUBLIC :: message INTERFACE message MODULE PROCEDURE messageascii MODULE PROCEDURE messagestr MODULE PROCEDURE messagestrascii ! BUG: Uncomment next line and it compiles MODULE PROCEDURE messagedt END INTERFACE message CONTAINS SUBROUTINE messageascii(m, str) USE ISO_FORTRAN_ENV, ONLY: output_unit CHARACTER(LEN=*), INTENT(IN) :: m, str write(*,*) m write(*,*) str END SUBROUTINE messageascii SUBROUTINE messagedt(m, SPEC) USE HS2DateTime, ONLY: HSDateTime USE HS2DateTime, ONLY: HSTimeSpec CHARACTER(LEN=*), INTENT(IN) :: m TYPE(HSTimeSpec), OPTIONAL, INTENT(IN) :: SPEC CALL HS_REFERENCE(m) IF (PRESENT(SPEC)) CALL HS_REFERENCE(SPEC) RETURN END SUBROUTINE messagedt SUBROUTINE messagestrascii(m, str) USE HS2String, ONLY: HSString TYPE(HSString), INTENT(IN) :: m CHARACTER(LEN=*), INTENT(IN) :: str CALL HS_REFERENCE(m) CALL HS_REFERENCE(str) END SUBROUTINE messagestrascii SUBROUTINE messagestr(m, str) CHARACTER(LEN=*), INTENT(IN) :: m TYPE(HSString), INTENT(IN) :: str CALL messageascii(m, "test") END SUBROUTINE messagestr END MODULE HS2Core ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2File USE HS2Kinds USE HS2Error, ONLY: HSError USE HS2String, ONLY: HSString IMPLICIT NONE PRIVATE PUBLIC :: HSFile TYPE HSFile TYPE(HSError) :: err CONTAINS PROCEDURE, PASS :: errorMessage END TYPE HSFile CONTAINS FUNCTION errorMessage(this) RESULT(answ) CLASS(HSFile), INTENT(IN) :: this TYPE(HSString) :: answ answ = this%err RETURN END FUNCTION errorMessage END MODULE HS2File ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! MODULE HS2Wavelets USE HS2Kinds IMPLICIT NONE PRIVATE TYPE HSWavelet CONTAINS PROCEDURE, PASS :: writeWavelet END TYPE HSWavelet CONTAINS SUBROUTINE writeWavelet(this) ! BUG: Comment out next line and it compiles or move it below the next ! three use statements USE HS2Core, ONLY: message ! BUG: Either move this line below the next two use statements or USE HS2File, ONLY: HSFile ! change the order of the next two lines and it compiles. USE HS2Error, ONLY: HSError USE HS2String, ONLY: HSString CLASS(HSWavelet), INTENT(IN) :: this TYPE(HSError) :: err TYPE(HSFile) :: file CALL HS_REFERENCE(this) err = file%errorMessage() err = err + file%errorMessage() RETURN END SUBROUTINE writeWavelet END MODULE HS2Wavelets ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! PROGRAM does_not_compile WRITE(*,*) "hmm" END PROGRAM does_not_compile