ad_dco_a1s_ti_marker_module.f

Go to the documentation of this file.

!!!    module AD_DCO_A1S_TI_MARKER_MODULE
!!!     A module that allows to store tape indicess for
!!!       later extraction of intenrmediate adjoints
!!!
!!!       Assumption :  contigouous storage
!!!   JR 2016


#if defined COMPAD    /* do that only for active compilation */

      MODULE dco_a1s_ti_marker_list_module
        USE dco_a1s_common
        IMPLICIT NONE
        TYPE dco_a1s_ti_marker_list_elem
        INTEGER(DCO_A1S_TAPE_IKND)     :: frst, size
!           INTEGER                        :: TSTP
        END TYPE dco_a1s_ti_marker_list_elem
        TYPE dco_a1s_ti_marker_list_type
        TYPE(dco_a1s_ti_marker_list_elem), ALLOCATABLE  :: data(:)
        END TYPE dco_a1s_ti_marker_list_type
      CONTAINS
        SUBROUTINE dco_a1s_ti_marker_list_setup( TIM, NIT )
          TYPE(dco_a1s_ti_marker_list_type) :: tim
          INTEGER, INTENT(IN)          :: NIT
          print *,'DCO_A1S_TI_MARKER_LIST_SETUP( ', nit,' )'
          IF ( nit < 0 ) THEN
            print *,'ERROR: DCO_A1S_TI_MARKER_LIST_SETUP :: NIT (',
     &            nit,') < 0 !!'
            stop
          END IF
          ALLOCATE( tim%DATA(0:nit))
          tim%DATA = dco_a1s_ti_marker_list_elem(0,0)
        END SUBROUTINE dco_a1s_ti_marker_list_setup
        SUBROUTINE dco_a1s_ti_marker_list_clean( TIM )
          TYPE(dco_a1s_ti_marker_list_type) :: TIM
          DEALLOCATE( tim%DATA )
        END SUBROUTINE dco_a1s_ti_marker_list_clean
        SUBROUTINE dco_a1s_ti_marker_list_store( TIM, TSTP, FRST, SIZE )
          TYPE(dco_a1s_ti_marker_list_type) :: TIM
          INTEGER,                     INTENT(IN)  :: TSTP
          INTEGER(DCO_A1S_TAPE_IKND),  INTENT(IN)  :: FRST, SIZE
          tim%DATA(tstp) = dco_a1s_ti_marker_list_elem( frst, SIZE )
        END SUBROUTINE dco_a1s_ti_marker_list_store
        SUBROUTINE dco_a1s_ti_marker_list_get( TIM, TSTP, FRST, SIZE )
          TYPE(dco_a1s_ti_marker_list_type),INTENT(IN) :: TIM
          INTEGER,                     INTENT(IN)  :: TSTP
          INTEGER(DCO_A1S_TAPE_IKND),  INTENT(OUT)  :: FRST, SIZE
          frst  = tim%DATA(tstp)%FRST
          SIZE  = tim%DATA(tstp)%SIZE
        END SUBROUTINE dco_a1s_ti_marker_list_get
        SUBROUTINE dco_a1s_ti_marker_list_print( TIM )
          TYPE(dco_a1s_ti_marker_list_type),INTENT(IN)  :: TIM
          INTEGER                                  :: I
          print *,'TIMDATA  : ',SIZE(tim%DATA,1),' elements'
          DO i = 0, SIZE(tim%DATA)-1
            print *,'TIMDATA ',i,' : ', tim%DATA(i)%FRST,
     &            ' -> ',tim%DATA(i)%FRST+tim%DATA(i)%SIZE,
     &            '  ( ',tim%DATA(i)%SIZE,' )'
          END DO
        END SUBROUTINE dco_a1s_ti_marker_list_print
      END MODULE dco_a1s_ti_marker_list_module

      MODULE dco_a1s_ti_marker_module
        USE dco_a1s_ti_marker_list_module
        IMPLICIT NONE
        PRIVATE
        PUBLIC :: dco_a1s_ti_marker
        PUBLIC :: dco_a1s_ti_marker_setup, dco_a1s_ti_marker_clean
        PUBLIC :: dco_a1s_ti_marker_store, dco_a1s_ti_marker_get
        PUBLIC :: dco_a1s_ti_marker_get_first
        PUBLIC :: dco_a1s_ti_marker_get_size
        PUBLIC :: dco_a1s_ti_marker_print
        TYPE(dco_a1s_ti_marker_list_type),
     &       DIMENSION(:), ALLOCATABLE :: dco_a1s_ti_marker
      CONTAINS
        SUBROUTINE dco_a1s_ti_marker_setup( NTIM, NIT )
          INTEGER, INTENT(IN)          :: ntim
          INTEGER, INTENT(IN)          :: NIT
          INTEGER                      :: I
          print *,'Called : DCO_A1S_TI_MARKER_SETUP(',ntim,',',nit,')'
          IF ( ntim < 1 ) THEN
            print *,'ERROR: DCO_A1S_TI_MARKER_SETUP :: NTIM (',
     &           ntim,') < 1 !!'
            stop
          END IF
          IF ( nit < 0 ) THEN
            print *,'ERROR: DCO_A1S_TI_MARKER_SETUP :: NIT (',
     &           nit,') < 0 !!'
            stop
          END IF
          ALLOCATE( dco_a1s_ti_marker(ntim) )
          DO i = 1, ntim
            CALL dco_a1s_ti_marker_list_setup( dco_a1s_ti_marker(i),
     &                                         nit )
          END DO
        END SUBROUTINE dco_a1s_ti_marker_setup
        SUBROUTINE dco_a1s_ti_marker_clean( )
          INTEGER                      :: I
          print *,'Called : DCO_A1S_TI_MARKER_CLEAN '
          DO i = 1, SIZE(dco_a1s_ti_marker)
            CALL dco_a1s_ti_marker_list_clean( dco_a1s_ti_marker(i) )
          END DO
          IF ( ALLOCATED( dco_a1s_ti_marker ) ) THEN
            DEALLOCATE( dco_a1s_ti_marker )
          ENDIF
        END SUBROUTINE dco_a1s_ti_marker_clean
        SUBROUTINE arg_check( TIM, TSTP, WHO )
          INTEGER,                     INTENT(IN)  :: TIM, TSTP
          CHARACTER(LEN=*),            INTENT(IN)  :: WHO
          IF ( tim < 1 .OR. tim > SIZE(dco_a1s_ti_marker,1) ) THEN
            print *,'ERROR: DCO_A1S_TI_MARKER_'//who
     &               //' :: INVALID TIM NUMBER ', tim, ' !!'
            stop
          END IF
          IF ( tstp < 0 .OR.
     &         tstp > SIZE(dco_a1s_ti_marker(tim)%DATA,1) ) THEN
            print *,'ERROR: DCO_A1S_TI_MARKER_'//who
     &              //' :: INVALID TSTP NUMBER ',tstp,
     &              '                    !!'
            stop
          END IF
        END SUBROUTINE arg_check
        SUBROUTINE dco_a1s_ti_marker_store( TIM, TSTP, FRST, SZE )
          INTEGER,                     INTENT(IN)  :: TIM, TSTP
          TYPE(dco_a1s_type),          INTENT(IN)  :: FRST
          INTEGER(DCO_A1S_TAPE_IKND),  INTENT(IN)  :: SZE
!          INTEGER(DCO_A1S_TAPE_IKND),  INTENT(IN)  :: FRST, sze
          print *,'Called : DCO_A1S_TI_MARKER_STORE(',tim,',',tstp,
     &            ',',frst,',',sze,')'
          CALL arg_check( tim, tstp, 'STORE' )
          CALL dco_a1s_ti_marker_list_store( dco_a1s_ti_marker(tim),
     &                                       tstp, frst%J, sze )
        END SUBROUTINE dco_a1s_ti_marker_store
        SUBROUTINE dco_a1s_ti_marker_get( TIM, TSTP, FRST, SZE )
          INTEGER,                     INTENT(IN)   :: TIM, TSTP
          INTEGER(DCO_A1S_TAPE_IKND),  INTENT(OUT)  :: FRST, SZE
          CALL arg_check( tim, tstp, 'GET' )
          CALL dco_a1s_ti_marker_list_get( dco_a1s_ti_marker(tim),
     &                                     tstp, frst, sze )
          print *,'Called : DCO_A1S_TI_MARKER_GET(',tim,',',tstp,
     &            ',->',frst,',->',SIZE,')'
        END SUBROUTINE dco_a1s_ti_marker_get
        FUNCTION dco_a1s_ti_marker_get_first( TIM, TSTP ) RESULT(RES)
          INTEGER,                     INTENT(IN)   :: TIM, TSTP
          INTEGER(DCO_A1S_TAPE_IKND)                :: FRST, SZE
          INTEGER(DCO_A1S_TAPE_IKND)                :: RES
          CALL arg_check( tim, tstp, 'GET_FIRST' )
          CALL dco_a1s_ti_marker_list_get( dco_a1s_ti_marker(tim),
     &                                     tstp, frst, sze )
          res = frst
          !!PRINT *,'Called : DCO_A1S_TI_MARKER_GET_FIRST(',TIM,',',TSTP,') ->',RES
        END FUNCTION dco_a1s_ti_marker_get_first
        FUNCTION dco_a1s_ti_marker_get_size( TIM, TSTP ) RESULT(RES)
          INTEGER,                     INTENT(IN)   :: TIM, TSTP
          INTEGER(DCO_A1S_TAPE_IKND)                :: FRST, SZE
          INTEGER(DCO_A1S_TAPE_IKND)                :: RES
          CALL arg_check( tim, tstp, 'GET_SIZE' )
          CALL dco_a1s_ti_marker_list_get( dco_a1s_ti_marker(tim),
     &                                     tstp, frst, sze )
          res = sze
          !!PRINT *,'Called : DCO_A1S_TI_MARKER_GET_FIRST(',TIM,',',TSTP,') ->',RES
        END FUNCTION dco_a1s_ti_marker_get_size
        SUBROUTINE dco_a1s_ti_marker_print( TIM )
          INTEGER, INTENT(IN)                       :: TIM
          IF ( tim < 1 .OR. tim > SIZE(dco_a1s_ti_marker,1) ) THEN
            print *,
     &          'ERROR: DCO_A1S_TI_MARKER_PRINT :: INVALID TIM NUMBER ',
     &            tim, ' !!'
            stop
          END IF
          CALL dco_a1s_ti_marker_list_print( dco_a1s_ti_marker(tim) )
        END  SUBROUTINE dco_a1s_ti_marker_print
      END MODULE dco_a1s_ti_marker_module

#endif /* COMPAD    ! do that only for active compilation */