Changeset 1200 for trunk/NEMO/OPA_SRC

Timestamp:

2008-09-24T15:05:20+02:00 (16 years ago)

Author:

rblod

Message:

Adapt Agrif to the new SBC and correct several bugs for agrif (restart writing and reading), see ticket #133
Note : this fix does not work yet on NEC computerq (sxf90/360)

Location:

trunk/NEMO/OPA_SRC

Files:

• DOM/dom_oce.F90 (modified) (1 diff)
• DYN/dynspg_flt.F90 (modified) (1 diff)
• IOM/iom.F90 (modified) (9 diffs)
• SBC/fldread.F90 (modified) (1 diff)
• SBC/sbcblk_clio.F90 (modified) (1 diff)
• SBC/sbcblk_core.F90 (modified) (2 diffs)
• SBC/sbcflx.F90 (modified) (1 diff)
• SBC/sbcice_if.F90 (modified) (1 diff)
• SBC/sbcrnf.F90 (modified) (1 diff)
• SBC/sbcssr.F90 (modified) (2 diffs)
• istate.F90 (modified) (2 diffs)

trunk/NEMO/OPA_SRC/DOM/dom_oce.F90

@@ -188 +188 @@
 
    !!----------------------------------------------------------------------
+   !! agrif domain
+   !!----------------------------------------------------------------------
+#if defined key_agrif
+   LOGICAL, PUBLIC, PARAMETER ::   lk_agrif = .TRUE.    !: agrif flag
+#else
+   LOGICAL, PUBLIC, PARAMETER ::   lk_agrif = .FALSE.   !: agrif flag
+#endif
+
+
+   !!----------------------------------------------------------------------
    !! time domain
    !!----------------------------------------------------------------------

trunk/NEMO/OPA_SRC/DYN/dynspg_flt.F90

@@ -141 +141 @@
 
          ! read filtered free surface arrays in restart file
-         CALL flt_rst( nit000, 'READ' )       ! read or initialize the following fields:
-         !                                    ! gcx, gcxb, sshb, sshn
+         ! when using agrif, sshn, gcx have to be read in istate
+         IF (.NOT. lk_agrif) CALL flt_rst( nit000, 'READ' )       ! read or initialize the following fields:
+         !                                                        ! gcx, gcxb, sshb, sshn
       ENDIF
 

trunk/NEMO/OPA_SRC/IOM/iom.F90

@@ -69 +69 @@
       LOGICAL               ::   llok      ! check the existence 
       LOGICAL               ::   llwrt     ! local definition of ldwrt
+      LOGICAL               ::   llnoov    ! local definition to read overlap
       LOGICAL               ::   llstop    ! local definition of ldstop
       INTEGER               ::   iolib     ! library do we use to open the file
@@ -104 +105 @@
       ELSE                         ;   iolib = jpnf90
       ENDIF
+      ! do we read the overlap 
+      ! ugly patch SM+JMM+RB to overwrite global definition in some cases
+      llnoov = (jpni * jpnj ) == jpni .AND. .NOT. lk_agrif 
       ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix)
       ! =============
       clname   = trim(cdname)
 #if defined key_agrif
-      if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
+      IF ( .NOT. Agrif_Root() ) THEN
+         iln    = INDEX(clname,'/') 
+         cltmpn = clname(1:iln)
+         clname = clname(iln+1:LEN_TRIM(clname))
+         clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname)
+      ENDIF
 #endif    
       ! which suffix should we use?
@@ -149 +158 @@
 ! JMM + SM: ugly patch before getting the new version of lib_mpp)
 !         idom = jpdom_local_noovlap   ! default definition
-         IF( jpni*jpnj == jpnij ) THEN   ;   idom = jpdom_local_noovlap   ! default definition
-         ELSE                            ;   idom = jpdom_local_full      ! default definition
+         IF( llnoov ) THEN   ;   idom = jpdom_local_noovlap   ! default definition
+         ELSE                ;   idom = jpdom_local_full      ! default definition
          ENDIF
          IF( PRESENT(kdom) )   idom = kdom
@@ -411 +420 @@
       INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis
       !
+      LOGICAL                        ::   llnoov      ! local definition to read overlap
       INTEGER                        ::   jl          ! loop on number of dimension 
       INTEGER                        ::   idom        ! type of domain
@@ -437 +447 @@
       ! local definition of the domain ?
       idom = kdom
+      ! do we read the overlap 
+      ! ugly patch SM+JMM+RB to overwrite global definition in some cases
+      llnoov = (jpni * jpnj ) == jpni .AND. .NOT. lk_agrif 
       ! check kcount and kstart optionals parameters...
       IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present')
@@ -520 +533 @@
 ! JMM + SM: ugly patch before getting the new version of lib_mpp)
 !                  IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
-                  IF( jpni*jpnj == jpnij .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
+                  IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
                   ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 
 ! JMM + SM: ugly patch before getting the new version of lib_mpp)
 !                  icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
-                  IF( jpni*jpnj == jpnij ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
-                  ELSE                            ;   icnt(1:2) = (/ nlci           , nlcj            /)
+                  IF( llnoov ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
+                  ELSE                ;   icnt(1:2) = (/ nlci           , nlcj            /)
                   ENDIF
                   IF( PRESENT(pv_r3d) ) THEN
@@ -558 +571 @@
 ! JMM + SM: ugly patch before getting the new version of lib_mpp)
 !               ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej  ))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej)'
-               IF( jpni*jpnj == jpnij ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)'
-               ELSE                          ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)'
+               IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)'
+               ELSE              ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)'
                ENDIF
             ENDIF
@@ -565 +578 @@
 ! JMM + SM: ugly patch before getting the new version of lib_mpp)
 !               ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej,:)'
-               IF( jpni*jpnj == jpnij ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'
-               ELSE                          ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)'
+               IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'
+               ELSE              ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)'
                ENDIF
             ENDIF
@@ -587 +600 @@
 !         ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
 !         ENDIF
-         IF( jpni*jpnj == jpnij ) THEN
+         IF( llnoov ) THEN
             IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej
             ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)

trunk/NEMO/OPA_SRC/SBC/fldread.F90

@@ -42 +42 @@
       REAL(wp) , DIMENSION(2)         ::   rec_b        ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year
       REAL(wp) , DIMENSION(2)         ::   rec_a        ! after  record (1: index, 2: second since Jan. 1st 00h of nit000 year
-      REAL(wp) , DIMENSION(jpi,jpj)   ::   fnow         ! input fields interpolated to now time step
-      REAL(wp) , DIMENSION(jpi,jpj,2) ::   fdta         ! 2 consecutive record of input fields
+      REAL(wp) , ALLOCATABLE, DIMENSION(:,:)   ::   fnow         ! input fields interpolated to now time step
+      REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:) ::   fdta         ! 2 consecutive record of input fields
    END TYPE FLD
 

trunk/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

@@ -163 +163 @@
             CALL ctl_stop( 'sbc_blk_clio: unable to allocate sf structure' )   ;   RETURN
          ENDIF
+
+         DO ifpr= 1, jpfld
+            ALLOCATE( sf(ifpr)%fnow(jpi,jpj) )
+            ALLOCATE( sf(ifpr)%fdta(jpi,jpj,2) )
+         END DO
+
 
          ! fill sf with slf_i and control print

trunk/NEMO/OPA_SRC/SBC/sbcblk_core.F90

@@ -108 +108 @@
       !!
       INTEGER  ::   ierror   ! return error code
+      INTEGER  ::   ifpr     ! dummy loop indice
       !!
       CHARACTER(len=100) ::  cn_dir   !   Root directory for location of core files
@@ -149 +150 @@
             CALL ctl_stop( 'sbc_blk_core: unable to allocate sf structure' )   ;   RETURN
          ENDIF
+
+         DO ifpr= 1, jpfld
+            ALLOCATE( sf(ifpr)%fnow(jpi,jpj) )
+            ALLOCATE( sf(ifpr)%fdta(jpi,jpj,2) )
+         END DO
 
          ! fill sf with slf_i and control print

trunk/NEMO/OPA_SRC/SBC/sbcflx.F90

@@ -133 +133 @@
             CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' )   ;   RETURN  
          ENDIF
+         DO ji= 1, jpfld
+            ALLOCATE( sf(ji)%fnow(jpi,jpj) )
+            ALLOCATE( sf(ji)%fdta(jpi,jpj,2) )
+         END DO
+
 
          ! fill sf with slf_i and control print

trunk/NEMO/OPA_SRC/SBC/sbcice_if.F90

@@ -80 +80 @@
             CALL ctl_stop( 'sbc_ice_if: unable to allocate sf_ice structure' )   ;   RETURN
          ENDIF
+         ALLOCATE( sf_ice(1)%fnow(jpi,jpj) )
+         ALLOCATE( sf_ice(1)%fdta(jpi,jpj,2) )
+
 
          ! fill sf_ice with sn_ice and control print

trunk/NEMO/OPA_SRC/SBC/sbcrnf.F90

@@ -152 +152 @@
             CALL ctl_stop( 'sbc_rnf: unable to allocate sf_rnf structure' )   ;   RETURN
          ENDIF
+         ALLOCATE( sf_rnf(1)%fnow(jpi,jpj) )
+         ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,2) )
 
          ! fill sf_rnf with sn_rnf and control print

trunk/NEMO/OPA_SRC/SBC/sbcssr.F90

@@ -111 +111 @@
                CALL ctl_stop( 'sbc_ssr: unable to allocate sf_sst structure' )   ;   RETURN
             ENDIF
+            ALLOCATE( sf_sst(1)%fnow(jpi,jpj) )
+            ALLOCATE( sf_sst(1)%fdta(jpi,jpj,2) )
+
             ! fill sf_sst with sn_sst and control print
             CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )
@@ -122 +125 @@
                CALL ctl_stop( 'sbc_ssr: unable to allocate sf_sss structure' )   ;   RETURN
             ENDIF
+            ALLOCATE( sf_sss(1)%fnow(jpi,jpj) )
+            ALLOCATE( sf_sss(1)%fdta(jpi,jpj,2) )
+
             ! fill sf_sss with sn_sss and control print
             CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )

trunk/NEMO/OPA_SRC/istate.F90

@@ -133 +133 @@
       ENDIF
 
-      IF( lk_vvl ) THEN
+      IF( lk_vvl .OR. lk_agrif ) THEN
          ! read free surface arrays in restart file
          IF( ln_rstart ) THEN
@@ -143 +143 @@
             !                                                         ! sshb, sshn
          ENDIF
+      ENDIF
+
+      IF( lk_vvl ) THEN
+
          !
          IF( .NOT. lk_dynspg_flt ) sshbb(:,:) = sshb(:,:)