Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

Timestamp:

2011-03-30T17:58:35+02:00 (13 years ago)

Author:

rblod

Message:

First attempt to put dynamic allocation on the trunk

File:

• trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90 (modified) (13 diffs)

trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

@@ -48 +48 @@
    USE dtatem
    USE dtasal
+   USE lib_mpp         ! MPP library
 
    IMPLICIT NONE
@@ -54 +55 @@
    PUBLIC   dia_wri                 ! routines called by step.F90
    PUBLIC   dia_wri_state
+   PUBLIC   dia_wri_alloc           ! Called by nemogcm module
 
    INTEGER ::   nid_T, nz_T, nh_T, ndim_T, ndim_hT   ! grid_T file
@@ -60 +62 @@
    INTEGER ::   nid_W, nz_W, nh_W                    ! grid_W file
    INTEGER ::   ndex(1)                              ! ???
-   INTEGER, DIMENSION(jpi*jpj)     ::   ndex_hT, ndex_hU, ndex_hV
-   INTEGER, DIMENSION(jpi*jpj*jpk) ::   ndex_T, ndex_U, ndex_V
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V
 
    !! * Substitutions
@@ -74 +76 @@
 CONTAINS
 
+   INTEGER FUNCTION dia_wri_alloc()
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(2) :: ierr
+      !!----------------------------------------------------------------------
+      !
+      ierr = 0
+      !
+      ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) ,     &
+         &      ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) ,     &
+         &      ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
+         !
+      dia_wri_alloc = MAXVAL(ierr)
+      IF( lk_mpp )   CALL mpp_sum( dia_wri_alloc )
+      !
+  END FUNCTION dia_wri_alloc
+
 #if defined key_dimgout
    !!----------------------------------------------------------------------
@@ -88 +106 @@
    !!   'key_iomput'                                        use IOM library
    !!----------------------------------------------------------------------
+
    SUBROUTINE dia_wri( kt )
       !!---------------------------------------------------------------------
@@ -98 +117 @@
       !!----------------------------------------------------------------------
       USE oce, ONLY :   z3d => ta   ! use ta as 3D workspace
+      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
+      USE wrk_nemo, ONLY: z2d => wrk_2d_1
       !!
       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
@@ -103 +124 @@
       INTEGER                      ::   ji, jj, jk              ! dummy loop indices
       REAL(wp)                     ::   zztmp, zztmpx, zztmpy   ! 
-      REAL(wp), DIMENSION(jpi,jpj) ::   z2d                     ! 
       !!----------------------------------------------------------------------
       ! 
+      IF( wrk_in_use(2, 1))THEN
+         CALL ctl_stop('dia_wri: ERROR - requested 2D workspace unavailable.')
+         RETURN
+      END IF
+      !
       ! Output the initial state and forcings
       IF( ninist == 1 ) THEN                       
@@ -175 +200 @@
       ENDIF
       !
+      IF( wrk_not_released(2, 1))THEN
+         CALL ctl_stop('dia_wri: ERROR - failed to release 2D workspace.')
+         RETURN
+      END IF
+      !
    END SUBROUTINE dia_wri
 
@@ -194 +224 @@
       !!      Each nwrite time step, output the instantaneous or mean fields
       !!----------------------------------------------------------------------
+      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
+      USE wrk_nemo, ONLY: zw2d => wrk_2d_1
+      !!
       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
       !!
@@ -201 +234 @@
       INTEGER  ::   iimi, iima, ipk, it, itmod, ijmi, ijma   ! local integers
       REAL(wp) ::   zsto, zout, zmax, zjulian, zdt           ! local scalars
-      REAL(wp), DIMENSION(jpi,jpj) ::   zw2d                 ! 2D workspace
       !!----------------------------------------------------------------------
+      !
+      IF( wrk_in_use(2, 1))THEN
+         CALL ctl_stop('dia_wri: ERROR - requested 2D workspace unavailable.')
+         RETURN
+      END IF
       !
       ! Output the initial state and forcings
@@ -502 +539 @@
       CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping
       CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping
-      zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)
+      IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)
       CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping
 #endif
@@ -508 +545 @@
       CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping
       CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping
-         zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)
+         IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)
       CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping
 #endif
@@ -570 +607 @@
          CALL histclo( nid_W )
       ENDIF
+      !
+      IF( wrk_not_released(2, 1))THEN
+         CALL ctl_stop('dia_wri: ERROR - failed to release 2D workspace.')
+         RETURN
+      END IF
       !
    END SUBROUTINE dia_wri