Juan 04/01/2021: mode_mnh_zwork.f90 , add new ZT1D & array routines for...

Juan 04/01/2021: mode_mnh_zwork.f90 , add new ZT1D & array routines for allocate/manage 1D array on rain_ice & openacc

src/MNH/mode_mnh_zwork.f90

@@ -19,7 +19,7 @@ MODULE MODE_MNH_ZWORK
   !
   INTEGER,SAVE                    :: IJS,IJN, IIW,IIA
   !
-  INTEGER, SAVE                   :: IIU,IJU,IKU
+  INTEGER, SAVE                   :: IIU,IJU,IKU,IIJKU
   LOGICAL, SAVE                   :: GWEST , GEAST
   LOGICAL, SAVE                   :: GSOUTH , GNORTH
 
@@ -37,7 +37,8 @@ MODULE MODE_MNH_ZWORK
   !REAL    , ALLOCATABLE, DIMENSION(:,:,:,:) , TARGET :: ZT3D_A1,ZT3D_A2,ZT3D_A3,ZT3D_A4
   !REAL    , POINTER    , DIMENSION(:,:,:,:)          :: ZT3D
   REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:)          :: ZT3D
-  
+
+  REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:)                :: ZT1D_OSIZE
   REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:)              :: ZT2D_OSIZE
   REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:,:)            :: ZT3D_OSIZE
   REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:)          :: ZT4D_OSIZE
@@ -53,6 +54,17 @@ MODULE MODE_MNH_ZWORK
   INTEGER , ALLOCATABLE, DIMENSION (:)      :: NT3D_POOL_G
   INTEGER                                   :: NT3D_TOP_G , NT3D_TOP_G_MAX = 0  
   LOGICAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:)       :: GT3D
+
+  INTEGER, parameter                        :: JPMAX_T3D_I = 4
+  INTEGER , ALLOCATABLE, DIMENSION (:)      :: NT3D_POOL_I
+  INTEGER                                   :: NT3D_TOP_I , NT3D_TOP_I_MAX = 0  
+  INTEGER,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:)       :: IT3D
+
+  INTEGER, parameter                        :: JPMAX_T1D_R = 60
+  INTEGER , ALLOCATABLE, DIMENSION (:)      :: NT1D_POOL_R
+  INTEGER                                   :: NT1D_TOP_R , NT1D_TOP_R_MAX = 0  
+  REAL,SAVE    , ALLOCATABLE, TARGET , DIMENSION(:,:)       :: ZT1D 
+  
   
 CONTAINS
 
@@ -76,6 +88,7 @@ CONTAINS
        !
        CALL GET_DIM_EXT_ll('B',IIU,IJU)     
        IKU=NKMAX + 2* JPVEXT
+       IIJKU = IIU*IJU*IKU
        !
        ! Computation bound
        !
@@ -113,10 +126,11 @@ CONTAINS
        ALLOCATE (ZT3D(IIU,IJU,IKU,JPMAX_T3D))
        !$acc enter data create(ZT3D)
 
+       ALLOCATE (ZT1D_OSIZE(0))
        ALLOCATE (ZT2D_OSIZE(IIU,0))
        ALLOCATE (ZT3D_OSIZE(IIU,IJU,0))
        ALLOCATE (ZT4D_OSIZE(IIU,IJU,IKU,0))
-       !$acc enter data create(ZT2D_OSIZE,ZT3D_OSIZE,ZT4D_OSIZE)      
+       !$acc enter data create(ZT1D_OSIZE,ZT2D_OSIZE,ZT3D_OSIZE,ZT4D_OSIZE)      
 
        ALLOCATE (NT3D_POOL(JPMAX_T3D))
        NT3D_TOP = 0
@@ -129,11 +143,33 @@ CONTAINS
        ALLOCATE (GT3D(IIU,IJU,IKU,JPMAX_T3D_G))
        !$acc enter data create(GT3D)
 
-       ALLOCATE (NT3D_POOL_G(JPMAX_T3D))
+       ALLOCATE (NT3D_POOL_G(JPMAX_T3D_G))
        NT3D_TOP_G = 0
-       DO JI = 1, JPMAX_T3D
+       DO JI = 1, JPMAX_T3D_G
           NT3D_POOL_G(JI) = JI
        END DO
+
+!------ Integer pool
+       
+       ALLOCATE (IT3D(IIU,IJU,IKU,JPMAX_T3D_I))
+       !$acc enter data create(IT3D)
+
+       ALLOCATE (NT3D_POOL_I(JPMAX_T3D_I))
+       NT3D_TOP_I = 0
+       DO JI = 1, JPMAX_T3D_I
+          NT3D_POOL_I(JI) = JI
+       END DO
+
+!------ Real 1D pool
+       
+       ALLOCATE (ZT1D(IIU*IJU*IKU,JPMAX_T1D_R))
+       !$acc enter data create(ZT1D)
+
+       ALLOCATE (NT1D_POOL_R(JPMAX_T1D_R))
+       NT1D_TOP_R = 0
+       DO JI = 1, JPMAX_T1D_R
+          NT1D_POOL_R(JI) = JI
+       END DO
        
 !------ Default values
        
@@ -145,12 +181,17 @@ CONTAINS
        ZUNIT3D = 1.0
 
        ZT3D  =  XUNDEF
+       ZT1D  =  XUNDEF
+
+       IT3D  = 0.0
+
+       GT3D  = .FALSE.
 
        !$acc end kernels
 
        !$acc update host (ZPSRC_HALO2_WEST,ZPSRC_HALO2_SOUTH)
        !$acc update host (ZUNIT3D)
-       !$acc update host (ZT3D)
+       !$acc update host (ZT3D,ZT1D)
 
     END IF
 
@@ -546,6 +587,161 @@ CONTAINS
        
   END FUNCTION MNH_ALLOCATE_GT3D
 
+  !------------ End Logical Pool
+
+  !-------- Real 1D Pool Managment
+  
+    SUBROUTINE MNH_GET_ZT1D_N0(KTEMP)
+
+    IMPLICIT NONE
+
+    INTEGER :: KTEMP
+
+    IF (NT1D_TOP_R == JPMAX_T1D_R ) THEN
+      WRITE( *, '( " MNH_GET_ZT1D_N0: NT1D_TOP_R too big (increaze JPMAX_T1D_R) , NT1D_TOP_R=",I4 )' ) NT1D_TOP_R
+      call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT1D_N0', 'NT1D_TOP_R too big (increaze JPMAX_T1D_R)' )
+    ELSE
+       NT1D_TOP_R = NT1D_TOP_R + 1
+       KTEMP = NT1D_POOL_R(NT1D_TOP_R)
+       NT1D_POOL_R(NT1D_TOP_R) = - KTEMP
+       IF (  NT1D_TOP_R > NT1D_TOP_R_MAX ) THEN
+          NT1D_TOP_R_MAX = NT1D_TOP_R
+          !WRITE( *, '( " MNH_GET_ZT1D: NT1D_TOP_R_MAX=",I4," KTEMP=",I4 )' ) NT1D_TOP_R_MAX,KTEMP
+       END IF
+    ENDIF
+    !WRITE( *, '( "MNH_GET_ZT1D: reserving ZT1D (",I4,")" )' ) KTEMP
+
+  END SUBROUTINE MNH_GET_ZT1D_N0
+
+  SUBROUTINE MNH_GET_ZT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+                          KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18)
+
+    IMPLICIT NONE
+
+    INTEGER          :: KTEMP1
+    INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+    INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+
+                          CALL MNH_GET_ZT1D_N0(KTEMP1)
+    IF (PRESENT(KTEMP2))  CALL MNH_GET_ZT1D_N0(KTEMP2)
+    IF (PRESENT(KTEMP3))  CALL MNH_GET_ZT1D_N0(KTEMP3)
+    IF (PRESENT(KTEMP4))  CALL MNH_GET_ZT1D_N0(KTEMP4)
+    IF (PRESENT(KTEMP5))  CALL MNH_GET_ZT1D_N0(KTEMP5)
+    IF (PRESENT(KTEMP6))  CALL MNH_GET_ZT1D_N0(KTEMP6)
+    IF (PRESENT(KTEMP7))  CALL MNH_GET_ZT1D_N0(KTEMP7)
+    IF (PRESENT(KTEMP8))  CALL MNH_GET_ZT1D_N0(KTEMP8)
+    IF (PRESENT(KTEMP9))  CALL MNH_GET_ZT1D_N0(KTEMP9)
+    IF (PRESENT(KTEMP10)) CALL MNH_GET_ZT1D_N0(KTEMP10)
+    IF (PRESENT(KTEMP11)) CALL MNH_GET_ZT1D_N0(KTEMP11)
+    IF (PRESENT(KTEMP12)) CALL MNH_GET_ZT1D_N0(KTEMP12)
+    IF (PRESENT(KTEMP13)) CALL MNH_GET_ZT1D_N0(KTEMP13)
+    IF (PRESENT(KTEMP14)) CALL MNH_GET_ZT1D_N0(KTEMP14)
+    IF (PRESENT(KTEMP15)) CALL MNH_GET_ZT1D_N0(KTEMP15)
+    IF (PRESENT(KTEMP16)) CALL MNH_GET_ZT1D_N0(KTEMP16)
+    IF (PRESENT(KTEMP17)) CALL MNH_GET_ZT1D_N0(KTEMP17)
+    IF (PRESENT(KTEMP18)) CALL MNH_GET_ZT1D_N0(KTEMP18)
+
+  END SUBROUTINE MNH_GET_ZT1D
+
+    SUBROUTINE MNH_REL_ZT1D_N0(KTEMP)
+
+    IMPLICIT NONE
+
+    INTEGER :: KTEMP
+
+    IF ( ( NT1D_TOP_R > JPMAX_T1D_R ) .OR. ( NT1D_TOP_R < 1 ) ) THEN
+      call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT1D_N0', 'invalid value for NT1D_TOP_R' )
+    ELSE
+      NT1D_POOL_R(KTEMP) = KTEMP
+      IF (KTEMP == NT1D_TOP_R) THEN
+        NT1D_TOP_R = NT1D_TOP_R - 1
+     ELSE
+        WRITE( *, '( "MNH_REL_ZT1D_N0: invalid value for KTEMP <> NT1D_TOP_R  (",2I8,")" )' ) KTEMP, NT1D_TOP_R
+        FLUSH(6)
+        call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT1D_N0', 'invalid value for KTEMP <> NT1D_TOP_R' )
+      END IF
+    ENDIF
+    !WRITE( *, '( "MNH_REL_ZT1D_N0: releasing ZT1D (",I4,")" )' ) KTEMP
+
+  END SUBROUTINE MNH_REL_ZT1D_N0
+
+  SUBROUTINE MNH_REL_ZT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+                          KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18, &
+                          KTEMP19,KTEMP20)
+
+    IMPLICIT NONE
+
+    INTEGER          :: KTEMP1
+    INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+    INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+    INTEGER,OPTIONAL :: KTEMP19,KTEMP20
+
+    IF (PRESENT(KTEMP20)) CALL MNH_REL_ZT1D_N0(KTEMP20)
+    IF (PRESENT(KTEMP19)) CALL MNH_REL_ZT1D_N0(KTEMP19)
+    IF (PRESENT(KTEMP18)) CALL MNH_REL_ZT1D_N0(KTEMP18)
+    IF (PRESENT(KTEMP17)) CALL MNH_REL_ZT1D_N0(KTEMP17)
+    IF (PRESENT(KTEMP16)) CALL MNH_REL_ZT1D_N0(KTEMP16)
+    IF (PRESENT(KTEMP15)) CALL MNH_REL_ZT1D_N0(KTEMP15)
+    IF (PRESENT(KTEMP14)) CALL MNH_REL_ZT1D_N0(KTEMP14)
+    IF (PRESENT(KTEMP13)) CALL MNH_REL_ZT1D_N0(KTEMP13)
+    IF (PRESENT(KTEMP12)) CALL MNH_REL_ZT1D_N0(KTEMP12)
+    IF (PRESENT(KTEMP11)) CALL MNH_REL_ZT1D_N0(KTEMP11)
+    IF (PRESENT(KTEMP10)) CALL MNH_REL_ZT1D_N0(KTEMP10)
+    IF (PRESENT(KTEMP9))  CALL MNH_REL_ZT1D_N0(KTEMP9)
+    IF (PRESENT(KTEMP8))  CALL MNH_REL_ZT1D_N0(KTEMP8)
+    IF (PRESENT(KTEMP7))  CALL MNH_REL_ZT1D_N0(KTEMP7)
+    IF (PRESENT(KTEMP6))  CALL MNH_REL_ZT1D_N0(KTEMP6)
+    IF (PRESENT(KTEMP5))  CALL MNH_REL_ZT1D_N0(KTEMP5)
+    IF (PRESENT(KTEMP4))  CALL MNH_REL_ZT1D_N0(KTEMP4)
+    IF (PRESENT(KTEMP3))  CALL MNH_REL_ZT1D_N0(KTEMP3)
+    IF (PRESENT(KTEMP2))  CALL MNH_REL_ZT1D_N0(KTEMP2)
+    CALL MNH_REL_ZT1D_N0(KTEMP1)
+    
+  END SUBROUTINE MNH_REL_ZT1D
+
+  FUNCTION MNH_ALLOCATE_ZT1D(PTAB,KI) RESULT (KINDEX)
+    
+    REAL, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+    INTEGER , INTENT(IN)    :: KI
+    INTEGER                 :: KINDEX
+
+    !local
+
+    IF (KI .EQ. IIU) THEN 
+       CALL MNH_GET_ZT1D_N0(KINDEX)
+       PTAB => ZT1D(:,KINDEX)
+    ELSE
+       call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT1D', ' Size mismatsh ' )
+    END IF
+    !WRITE( *, '( "MNH_ALLOCATE_ZT1D: KI=(",I4,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+    !FLUSH(6) 
+       
+  END FUNCTION MNH_ALLOCATE_ZT1D
+
+  FUNCTION MNH_ALLOCATE_ZT1DP(PTAB,KI) RESULT (KINDEX)
+    
+    REAL, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+    INTEGER , INTENT(IN)    :: KI
+    INTEGER                 :: KINDEX
+
+    !local
+
+    IF (KI .LE. IIJKU) THEN 
+       CALL MNH_GET_ZT1D_N0(KINDEX)
+       IF (KI .NE. 0) THEN
+          PTAB(1:KI) => ZT1D(:,KINDEX)
+       ELSE
+          PTAB => ZT1D_OSIZE
+       END IF
+    ELSE
+       call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT1DP', ' Size mismatsh ' )
+    END IF
+    !WRITE( *, '( "MNH_ALLOCATE_ZT1DP: KI=(",I9,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+    
+  END FUNCTION MNH_ALLOCATE_ZT1DP
+
+  ! End Real 1D management
+
   SUBROUTINE MNH_CHECK_IN_ZT3D(HSUB)
     IMPLICIT NONE