Changeset 5185 for LMDZ6/branches/Amaury_dev/libf/dyn3dmem

Timestamp:

Sep 11, 2024, 4:27:07 PM (16 months ago)

Author:

abarral

Message:

Replace REPROBUS CPP KEY by logical using handmade wonky wrapper

Location:

LMDZ6/branches/Amaury_dev/libf/dyn3dmem

Files:

• dynetat0_loc.f90 (moved) (moved from LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dynetat0_loc.F90) (2 diffs)
• leapfrog_loc.f90 (moved) (moved from LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.F90) (12 diffs)

LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dynetat0_loc.f90

@@ -1 @@
-SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
-
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , L.Fairhead
-!-------------------------------------------------------------------------------
-! Purpose: Initial state reading.
-!-------------------------------------------------------------------------------
+SUBROUTINE dynetat0_loc(fichnom, vcov, ucov, teta, q, masse, ps, phis, time)
+
+  !-------------------------------------------------------------------------------
+  ! Authors: P. Le Van , L.Fairhead
+  !-------------------------------------------------------------------------------
+  ! Purpose: Initial state reading.
+  !-------------------------------------------------------------------------------
   USE parallel_lmdz
-  USE lmdz_infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName
+  USE lmdz_infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName
   USE lmdz_strings, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
-  USE netcdf,      ONLY: nf90_open,  nf90_nowrite, nf90_inquire_dimension, nf90_inq_varid, &
-                         nf90_close, nf90_get_var, nf90_inquire_variable,  nf90_noerr
+  USE netcdf, ONLY: nf90_open, nf90_nowrite, nf90_inquire_dimension, nf90_inq_varid, &
+          nf90_close, nf90_get_var, nf90_inquire_variable, nf90_noerr
   USE lmdz_readTracFiles, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey
   USE control_mod, ONLY: planet_type
   USE lmdz_assert_eq, ONLY: assert_eq
-  USE comvert_mod, ONLY: pa,preff
+  USE comvert_mod, ONLY: pa, preff
   USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
   USE logic_mod, ONLY: fxyhypb, ysinus
   USE serre_mod, ONLY: clon, clat, grossismx, grossismy
   USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
+  USE ener_mod, ONLY: etot0, ptot0, ztot0, stot0, ang0
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
   USE lmdz_description, ONLY: descript
   USE lmdz_iniprint, ONLY: lunout, prt_level
   USE lmdz_comgeom
 
-USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
+  USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
   USE lmdz_paramet
   IMPLICIT NONE
 
 
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
-  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
-  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
-  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
-  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
-  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
-  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
-  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
-!===============================================================================
-! Local variables:
-  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
-  INTEGER, PARAMETER :: length=100
+  !===============================================================================
+  ! Arguments:
+  CHARACTER(LEN = *), INTENT(IN) :: fichnom          !--- FILE NAME
+  REAL, INTENT(OUT) :: vcov(ijb_v:ije_v, llm)      !--- V COVARIANT WIND
+  REAL, INTENT(OUT) :: ucov(ijb_u:ije_u, llm)      !--- U COVARIANT WIND
+  REAL, INTENT(OUT) :: teta(ijb_u:ije_u, llm)      !--- POTENTIAL TEMP.
+  REAL, INTENT(OUT) :: q(ijb_u:ije_u, llm, nqtot)!--- TRACERS
+  REAL, INTENT(OUT) :: masse(ijb_u:ije_u, llm)      !--- MASS PER CELL
+  REAL, INTENT(OUT) :: ps(ijb_u:ije_u)          !--- GROUND PRESSURE
+  REAL, INTENT(OUT) :: phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
+  !===============================================================================
+  ! Local variables:
+  CHARACTER(LEN = maxlen) :: mesg, var, modname, oldVar
+  INTEGER, PARAMETER :: length = 100
   INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix
-  REAL    :: time,tab_cntrl(length)    !--- RUN PARAMS TABLE
-  REAL    :: tnat, alpha_ideal
-  REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
-  REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
-  REAL,             ALLOCATABLE :: teta_glo(:,:)
+  REAL :: time, tab_cntrl(length)    !--- RUN PARAMS TABLE
+  REAL :: tnat, alpha_ideal
+  REAL, ALLOCATABLE :: vcov_glo(:, :), masse_glo(:, :), ps_glo(:)
+  REAL, ALLOCATABLE :: ucov_glo(:, :), q_glo(:, :), phis_glo(:)
+  REAL, ALLOCATABLE :: teta_glo(:, :)
   LOGICAL :: lSkip, ll
-  LOGICAL,PARAMETER :: tnat1=.TRUE.
-!-------------------------------------------------------------------------------
-  modname="dynetat0_loc"
-
-!--- Initial state file opening
-  var=fichnom
-  CALL err(nf90_open(var,nf90_nowrite,fID),"open",var)
-  CALL get_var1("controle",tab_cntrl)
-
-!!! AS: idecal is a hack to be able to read planeto starts...
-!!!     .... while keeping everything OK for LMDZ EARTH
+  LOGICAL, PARAMETER :: tnat1 = .TRUE.
+  !-------------------------------------------------------------------------------
+  modname = "dynetat0_loc"
+
+  !--- Initial state file opening
+  var = fichnom
+  CALL err(nf90_open(var, nf90_nowrite, fID), "open", var)
+  CALL get_var1("controle", tab_cntrl)
+
+  !!! AS: idecal is a hack to be able to read planeto starts...
+  !!!     .... while keeping everything OK for LMDZ EARTH
   IF(planet_type=="generic") THEN
     CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
     idecal = 4
-    annee_ref  = 2000
+    annee_ref = 2000
   ELSE
     CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
     idecal = 5
-    annee_ref  = tab_cntrl(5)
+    annee_ref = tab_cntrl(5)
   END IF
-  im         = tab_cntrl(1)
-  jm         = tab_cntrl(2)
-  lllm       = tab_cntrl(3)
-  day_ref    = tab_cntrl(4)
-  rad        = tab_cntrl(idecal+1)
-  omeg       = tab_cntrl(idecal+2)
-  g          = tab_cntrl(idecal+3)
-  cpp        = tab_cntrl(idecal+4)
-  kappa      = tab_cntrl(idecal+5)
-  daysec     = tab_cntrl(idecal+6)
-  dtvr       = tab_cntrl(idecal+7)
-  etot0      = tab_cntrl(idecal+8)
-  ptot0      = tab_cntrl(idecal+9)
-  ztot0      = tab_cntrl(idecal+10)
-  stot0      = tab_cntrl(idecal+11)
-  ang0       = tab_cntrl(idecal+12)
-  pa         = tab_cntrl(idecal+13)
-  preff      = tab_cntrl(idecal+14)
-
-  clon       = tab_cntrl(idecal+15)
-  clat       = tab_cntrl(idecal+16)
-  grossismx  = tab_cntrl(idecal+17)
-  grossismy  = tab_cntrl(idecal+18)
-
-  IF ( tab_cntrl(idecal+19)==1. )  THEN
-    fxyhypb  = .TRUE.
-!   dzoomx   = tab_cntrl(25)
-!   dzoomy   = tab_cntrl(26)
-!   taux     = tab_cntrl(28)
-!   tauy     = tab_cntrl(29)
+  im = tab_cntrl(1)
+  jm = tab_cntrl(2)
+  lllm = tab_cntrl(3)
+  day_ref = tab_cntrl(4)
+  rad = tab_cntrl(idecal + 1)
+  omeg = tab_cntrl(idecal + 2)
+  g = tab_cntrl(idecal + 3)
+  cpp = tab_cntrl(idecal + 4)
+  kappa = tab_cntrl(idecal + 5)
+  daysec = tab_cntrl(idecal + 6)
+  dtvr = tab_cntrl(idecal + 7)
+  etot0 = tab_cntrl(idecal + 8)
+  ptot0 = tab_cntrl(idecal + 9)
+  ztot0 = tab_cntrl(idecal + 10)
+  stot0 = tab_cntrl(idecal + 11)
+  ang0 = tab_cntrl(idecal + 12)
+  pa = tab_cntrl(idecal + 13)
+  preff = tab_cntrl(idecal + 14)
+
+  clon = tab_cntrl(idecal + 15)
+  clat = tab_cntrl(idecal + 16)
+  grossismx = tab_cntrl(idecal + 17)
+  grossismy = tab_cntrl(idecal + 18)
+
+  IF (tab_cntrl(idecal + 19)==1.)  THEN
+    fxyhypb = .TRUE.
+    !   dzoomx   = tab_cntrl(25)
+    !   dzoomy   = tab_cntrl(26)
+    !   taux     = tab_cntrl(28)
+    !   tauy     = tab_cntrl(29)
   ELSE
     fxyhypb = .FALSE.
-    ysinus  = tab_cntrl(idecal+22)==1.
+    ysinus = tab_cntrl(idecal + 22)==1.
   END IF
 
-  day_ini    = tab_cntrl(30)
-  itau_dyn   = tab_cntrl(31)
+  day_ini = tab_cntrl(30)
+  itau_dyn = tab_cntrl(31)
   start_time = tab_cntrl(32)
 
-!-------------------------------------------------------------------------------
-  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
-  CALL check_dim(im,iim,'im','im')
-  CALL check_dim(jm,jjm,'jm','jm')
-  CALL check_dim(lllm,llm,'lm','lllm')
-  CALL get_var1("rlonu",rlonu)
-  CALL get_var1("rlatu",rlatu)
-  CALL get_var1("rlonv",rlonv)
-  CALL get_var1("rlatv",rlatv)
-  CALL get_var1("cu"  ,cu)
-  CALL get_var1("cv"  ,cv)
-  CALL get_var1("aire",aire)
-
-  var="temps"
-  IF(nf90_inq_varid(fID,var,vID)/=nf90_noerr) THEN
+  !-------------------------------------------------------------------------------
+  CALL msg('rad, omeg, g, cpp, kappa = ' // TRIM(strStack(real2str([rad, omeg, g, cpp, kappa]))), modname)
+  CALL check_dim(im, iim, 'im', 'im')
+  CALL check_dim(jm, jjm, 'jm', 'jm')
+  CALL check_dim(lllm, llm, 'lm', 'lllm')
+  CALL get_var1("rlonu", rlonu)
+  CALL get_var1("rlatu", rlatu)
+  CALL get_var1("rlonv", rlonv)
+  CALL get_var1("rlatv", rlatv)
+  CALL get_var1("cu", cu)
+  CALL get_var1("cv", cv)
+  CALL get_var1("aire", aire)
+
+  var = "temps"
+  IF(nf90_inq_varid(fID, var, vID)/=nf90_noerr) THEN
     CALL msg('missing field <temps> ; trying with <Time>', modname)
-    var="Time"
-    CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
+    var = "Time"
+    CALL err(nf90_inq_varid(fID, var, vID), "inq", var)
   END IF
-  CALL err(nf90_get_var(fID,vID,time),"get",var)
+  CALL err(nf90_get_var(fID, vID, time), "get", var)
 
   ALLOCATE(phis_glo(ip1jmp1))
-  CALL get_var1("phisinit",phis_glo)
-  phis (ijb_u:ije_u)  =phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
-
-  ALLOCATE(ucov_glo(ip1jmp1,llm))
-  CALL get_var2("ucov",ucov_glo)
-  ucov (ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:);  DEALLOCATE(ucov_glo)
-
-  ALLOCATE(vcov_glo(ip1jm,llm))
-  CALL get_var2("vcov",vcov_glo)
-  vcov (ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:);  DEALLOCATE(vcov_glo)
-
-  ALLOCATE(teta_glo(ip1jmp1,llm))
-  CALL get_var2("teta",teta_glo)
-  teta (ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:);  DEALLOCATE(teta_glo)
-
-  ALLOCATE(masse_glo(ip1jmp1,llm))
-  CALL get_var2("masse",masse_glo)
-  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:); DEALLOCATE(masse_glo)
-  
+  CALL get_var1("phisinit", phis_glo)
+  phis (ijb_u:ije_u) = phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
+
+  ALLOCATE(ucov_glo(ip1jmp1, llm))
+  CALL get_var2("ucov", ucov_glo)
+  ucov (ijb_u:ije_u, :) = ucov_glo(ijb_u:ije_u, :);  DEALLOCATE(ucov_glo)
+
+  ALLOCATE(vcov_glo(ip1jm, llm))
+  CALL get_var2("vcov", vcov_glo)
+  vcov (ijb_v:ije_v, :) = vcov_glo(ijb_v:ije_v, :);  DEALLOCATE(vcov_glo)
+
+  ALLOCATE(teta_glo(ip1jmp1, llm))
+  CALL get_var2("teta", teta_glo)
+  teta (ijb_u:ije_u, :) = teta_glo(ijb_u:ije_u, :);  DEALLOCATE(teta_glo)
+
+  ALLOCATE(masse_glo(ip1jmp1, llm))
+  CALL get_var2("masse", masse_glo)
+  masse(ijb_u:ije_u, :) = masse_glo(ijb_u:ije_u, :); DEALLOCATE(masse_glo)
+
   ALLOCATE(ps_glo(ip1jmp1))
-  CALL get_var1("ps",ps_glo)
-  ps   (ijb_u:ije_u)  =   ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
-
-!--- Tracers
-  ALLOCATE(q_glo(ip1jmp1,llm))
+  CALL get_var1("ps", ps_glo)
+  ps   (ijb_u:ije_u) = ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
+
+  !--- Tracers
+  ALLOCATE(q_glo(ip1jmp1, llm))
   ll = .FALSE.
-#ifdef REPROBUS
-  ll = nf90_inq_varid(fID, 'HNO3tot', vID) /= nf90_noerr                                 !--- DETECT OLD REPRO start.nc FILE
-#endif
-  DO iq=1,nqtot
+  IF (CPPKEY_REPROBUS) THEN
+    ll = nf90_inq_varid(fID, 'HNO3tot', vID) /= nf90_noerr                                 !--- DETECT OLD REPRO start.nc FILE
+  END IF
+  DO iq = 1, nqtot
     var = tracers(iq)%name
     oldVar = new2oldH2O(var)
     lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
-#ifdef REPROBUS
-    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
-#endif
+    IF (CPPKEY_REPROBUS) THEN
+      ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
+    END IF
     IF (CPPKEY_INCA) THEN
       IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
@@ -173 +173 @@
     !--------------------------------------------------------------------------------------------------------------------------
     IF(nf90_inq_varid(fID, var, vID) == nf90_noerr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
-      CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
-    !--------------------------------------------------------------------------------------------------------------------------
+      CALL get_var2(var, q_glo); q(ijb_u:ije_u, :, iq) = q_glo(ijb_u:ije_u, :)
+      !--------------------------------------------------------------------------------------------------------------------------
     ELSE IF(nf90_inq_varid(fID, oldVar, vID) == nf90_noerr) THEN                         !=== TRY WITH ALTERNATE NAME
-      CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname)
-      CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
-    !--------------------------------------------------------------------------------------------------------------------------
+      CALL msg('Tracer <' // TRIM(var) // '> is missing => initialized to <' // TRIM(oldVar) // '>', modname)
+      CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u, :, iq) = q_glo(ijb_u:ije_u, :)
+      !--------------------------------------------------------------------------------------------------------------------------
     ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
-      iName    = tracers(iq)%iso_iName
-      iPhase   = tracers(iq)%iso_iPhase
+      iName = tracers(iq)%iso_iName
+      iPhase = tracers(iq)%iso_iPhase
       iqParent = tracers(iq)%iqParent
       IF(tracers(iq)%iso_iZone == 0) THEN
-         IF (tnat1) THEN
-                 tnat=1.0
-                 alpha_ideal=1.0
-                 WRITE(*,*) 'attention dans dynetat0: les alpha_ideal sont a 1'
-         else
+        IF (tnat1) THEN
+          tnat = 1.0
+          alpha_ideal = 1.0
+          WRITE(*, *) 'attention dans dynetat0: les alpha_ideal sont a 1'
+        else
           IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
-            CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
-         endif
-         CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname)
-         q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-         ! Camille 9 mars 2023: point de vigilence: initialisation incohérente
-         ! avec celle de xt_ancien dans la physiq.
+                  CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
+        endif
+        CALL msg('Tracer <' // TRIM(var) // '> is missing => initialized with a simplified Rayleigh distillation law.', modname)
+        q(ijb_u:ije_u, :, iq) = q(ijb_u:ije_u, :, iqParent) * tnat * (q(ijb_u:ije_u, :, iqParent) / 30.e-3)**(alpha_ideal - 1.)
+        ! Camille 9 mars 2023: point de vigilence: initialisation incohérente
+        ! avec celle de xt_ancien dans la physiq.
       ELSE
-         CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to its parent isotope concentration.', modname)
-         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
-         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
-         ! les parents. Sinon, c'est nul.
-         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
-         ! remplacant 1 par izone_init dans la ligne qui suit.
-         IF(tracers(iq)%iso_iZone == 1) THEN
-           q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
-         ELSE
-           q(ijb_u:ije_u,:,iq) =  0.
-         ENDIF
+        CALL msg('Tracer <' // TRIM(var) // '> is missing => initialized to its parent isotope concentration.', modname)
+        ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
+        ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
+        ! les parents. Sinon, c'est nul.
+        ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
+        ! remplacant 1 par izone_init dans la ligne qui suit.
+        IF(tracers(iq)%iso_iZone == 1) THEN
+          q(ijb_u:ije_u, :, iq) = q(ijb_u:ije_u, :, iqIsoPha(iName, iPhase))
+        ELSE
+          q(ijb_u:ije_u, :, iq) = 0.
+        ENDIF
       END IF
-    !--------------------------------------------------------------------------------------------------------------------------
+      !--------------------------------------------------------------------------------------------------------------------------
     ELSE                                                                                 !=== MISSING: SET TO 0
-      CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to zero', modname)
-      q(ijb_u:ije_u,:,iq)=0.
-    !--------------------------------------------------------------------------------------------------------------------------
+      CALL msg('Tracer <' // TRIM(var) // '> is missing => initialized to zero', modname)
+      q(ijb_u:ije_u, :, iq) = 0.
+      !--------------------------------------------------------------------------------------------------------------------------
     END IF
   END DO
   DEALLOCATE(q_glo)
-  CALL err(nf90_close(fID),"close",fichnom)
-  day_ini=day_ini+INT(time)
-  time=time-INT(time)
-
-
-  CONTAINS
-
-
-SUBROUTINE check_dim(n1,n2,str1,str2)
-  INTEGER,          INTENT(IN) :: n1, n2
-  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
-  CHARACTER(LEN=maxlen) :: s1, s2
-  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
-   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
-END SUBROUTINE check_dim
-
-
-SUBROUTINE get_var1(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:)
-  REAL,             ALLOCATABLE :: w2(:,:), w3(:,:,:)
-  INTEGER :: nn(3), dids(3), k, nd, ntot
-
-  CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
-  ierr=nf90_inquire_variable(fID,vID,ndims=nd)
-  IF(nd==1) THEN
-    CALL err(nf90_get_var(fID,vID,v),"get",var); RETURN
-  END IF
-  ierr=nf90_inquire_variable(fID,vID,dimids=dids)
-  DO k=1,nd; ierr=nf90_inquire_dimension(fID,dids(k),len=nn(k)); END DO
-  ntot=PRODUCT(nn(1:nd))
-  SELECT CASE(nd)
-    CASE(2); ALLOCATE(w2(nn(1),nn(2)))
-      CALL err(nf90_get_var(fID,vID,w2),"get",var)
-      v=RESHAPE(w2,[ntot]); DEALLOCATE(w2)
-    CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
-      CALL err(nf90_get_var(fID,vID,w3),"get",var)
-      v=RESHAPE(w3,[ntot]); DEALLOCATE(w3)
-  END SELECT
-END SUBROUTINE get_var1
-
-SUBROUTINE get_var2(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:,:)
-  REAL,             ALLOCATABLE :: w4(:,:,:,:), w3(:,:,:)
-  INTEGER :: nn(4), dids(4), k, nd
-
-
-  CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
-  ierr=nf90_inquire_variable(fID,vID,ndims=nd)
-
-  IF(nd==1) THEN
-    CALL err(nf90_get_var(fID,vID,v),"get",var); RETURN
-  END IF
-  ierr=nf90_inquire_variable(fID,vID,dimids=dids)
-
-  DO k=1,nd; ierr=nf90_inquire_dimension(fID,dids(k),len=nn(k)); END DO
-
-  SELECT CASE(nd)
-  CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
-     CALL err(nf90_get_var(fID,vID,w3),"get",var)
-     v=RESHAPE(w3,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w3)
-  CASE(4);  ALLOCATE(w4(nn(1),nn(2),nn(3),nn(4)))
-     CALL err(nf90_get_var(fID,vID,w4),"get",var)
-     v=RESHAPE(w4,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w4)
-  END SELECT
-END SUBROUTINE get_var2
-
-
-SUBROUTINE err(ierr,typ,nam)
-  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
-  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
-  IF(ierr==nf90_noerr) RETURN
-  SELECT CASE(typ)
-    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
-    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
-    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
-    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
-  END SELECT
-  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
-END SUBROUTINE err
+  CALL err(nf90_close(fID), "close", fichnom)
+  day_ini = day_ini + INT(time)
+  time = time - INT(time)
+
+
+CONTAINS
+
+
+  SUBROUTINE check_dim(n1, n2, str1, str2)
+    INTEGER, INTENT(IN) :: n1, n2
+    CHARACTER(LEN = *), INTENT(IN) :: str1, str2
+    CHARACTER(LEN = maxlen) :: s1, s2
+    IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "' // TRIM(str1) // '" = ' // TRIM(int2str(n1)) // &
+            ' read in starting file differs from gcm value of "' // TRIM(str2) // '" = ' // TRIM(int2str(n2)), 1)
+  END SUBROUTINE check_dim
+
+
+  SUBROUTINE get_var1(var, v)
+    CHARACTER(LEN = *), INTENT(IN) :: var
+    REAL, INTENT(OUT) :: v(:)
+    REAL, ALLOCATABLE :: w2(:, :), w3(:, :, :)
+    INTEGER :: nn(3), dids(3), k, nd, ntot
+
+    CALL err(nf90_inq_varid(fID, var, vID), "inq", var)
+    ierr = nf90_inquire_variable(fID, vID, ndims = nd)
+    IF(nd==1) THEN
+      CALL err(nf90_get_var(fID, vID, v), "get", var); RETURN
+    END IF
+    ierr = nf90_inquire_variable(fID, vID, dimids = dids)
+    DO k = 1, nd; ierr = nf90_inquire_dimension(fID, dids(k), len = nn(k));
+    END DO
+    ntot = PRODUCT(nn(1:nd))
+    SELECT CASE(nd)
+    CASE(2); ALLOCATE(w2(nn(1), nn(2)))
+    CALL err(nf90_get_var(fID, vID, w2), "get", var)
+    v = RESHAPE(w2, [ntot]); DEALLOCATE(w2)
+    CASE(3); ALLOCATE(w3(nn(1), nn(2), nn(3)))
+    CALL err(nf90_get_var(fID, vID, w3), "get", var)
+    v = RESHAPE(w3, [ntot]); DEALLOCATE(w3)
+    END SELECT
+  END SUBROUTINE get_var1
+
+  SUBROUTINE get_var2(var, v)
+    CHARACTER(LEN = *), INTENT(IN) :: var
+    REAL, INTENT(OUT) :: v(:, :)
+    REAL, ALLOCATABLE :: w4(:, :, :, :), w3(:, :, :)
+    INTEGER :: nn(4), dids(4), k, nd
+
+    CALL err(nf90_inq_varid(fID, var, vID), "inq", var)
+    ierr = nf90_inquire_variable(fID, vID, ndims = nd)
+
+    IF(nd==1) THEN
+      CALL err(nf90_get_var(fID, vID, v), "get", var); RETURN
+    END IF
+    ierr = nf90_inquire_variable(fID, vID, dimids = dids)
+
+    DO k = 1, nd; ierr = nf90_inquire_dimension(fID, dids(k), len = nn(k));
+    END DO
+
+    SELECT CASE(nd)
+    CASE(3); ALLOCATE(w3(nn(1), nn(2), nn(3)))
+    CALL err(nf90_get_var(fID, vID, w3), "get", var)
+    v = RESHAPE(w3, [nn(1) * nn(2), nn(3)]); DEALLOCATE(w3)
+    CASE(4);  ALLOCATE(w4(nn(1), nn(2), nn(3), nn(4)))
+    CALL err(nf90_get_var(fID, vID, w4), "get", var)
+    v = RESHAPE(w4, [nn(1) * nn(2), nn(3)]); DEALLOCATE(w4)
+    END SELECT
+  END SUBROUTINE get_var2
+
+
+  SUBROUTINE err(ierr, typ, nam)
+    INTEGER, INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
+    CHARACTER(LEN = *), INTENT(IN) :: typ    !--- TYPE OF OPERATION
+    CHARACTER(LEN = *), INTENT(IN) :: nam    !--- FIELD/FILE NAME
+    IF(ierr==nf90_noerr) RETURN
+    SELECT CASE(typ)
+    CASE('inq');   mesg = "Field <" // TRIM(nam) // "> is missing"
+    CASE('get');   mesg = "Reading failed for <" // TRIM(nam) // ">"
+    CASE('open');  mesg = "File opening failed for <" // TRIM(nam) // ">"
+    CASE('close'); mesg = "File closing failed for <" // TRIM(nam) // ">"
+    END SELECT
+    CALL ABORT_gcm(TRIM(modname), TRIM(mesg), ierr)
+  END SUBROUTINE err
 
 END SUBROUTINE dynetat0_loc

LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.f90

@@ -39 +39 @@
           xios_set_current_context, &
           using_xios
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO, CPPKEY_REPROBUS
   USE lmdz_description, ONLY: descript
   USE lmdz_iniprint, ONLY: lunout, prt_level
@@ -81 +81 @@
   !   Declarations:
   !   -------------
-
-
-
 
   REAL, INTENT(IN) :: time_0 ! not used
@@ -319 +316 @@
 
   IF (ok_guide) THEN
-    CALL guide_main(itau,ucov,vcov,teta,q,masse,ps)
-!$OMP BARRIER
+    CALL guide_main(itau, ucov, vcov, teta, q, masse, ps)
+    !$OMP BARRIER
   ENDIF
 
@@ -796 +793 @@
   !c$OMP END PARALLEL
 
-
-
   IF(apphys)  THEN
 
@@ -952 +947 @@
     endif
 
-      IF (ANY(type_trac == ['inca', 'inco'])) THEN
-        CALL finalize_inca
-        ! switching back to LMDZDYN context
-        !$OMP MASTER
-        IF (ok_dyn_xios) THEN
-          CALL xios_set_current_context(dyn3d_ctx_handle)
-        ENDIF
-        !$OMP END MASTER
+    IF (ANY(type_trac == ['inca', 'inco'])) THEN
+      CALL finalize_inca
+      ! switching back to LMDZDYN context
+      !$OMP MASTER
+      IF (ok_dyn_xios) THEN
+        CALL xios_set_current_context(dyn3d_ctx_handle)
       ENDIF
-#ifdef REPROBUS
-     IF (type_trac == 'repr') CALL finalize_reprobus
-#endif
+      !$OMP END MASTER
+    ENDIF
+    IF (CPPKEY_REPROBUS) THEN
+      IF (type_trac == 'repr') CALL finalize_reprobus
+    END IF
 
     !$OMP MASTER
@@ -1005 +1000 @@
       !$OMP END MASTER
 
-        IF (ANY(type_trac == ['inca', 'inco'])) THEN
-          CALL finalize_inca
-          ! switching back to LMDZDYN context
-          !$OMP MASTER
-          IF (ok_dyn_xios) THEN
-            CALL xios_set_current_context(dyn3d_ctx_handle)
-          ENDIF
-          !$OMP END MASTER
+      IF (ANY(type_trac == ['inca', 'inco'])) THEN
+        CALL finalize_inca
+        ! switching back to LMDZDYN context
+        !$OMP MASTER
+        IF (ok_dyn_xios) THEN
+          CALL xios_set_current_context(dyn3d_ctx_handle)
         ENDIF
-#ifdef REPROBUS
-          IF (type_trac == 'repr') CALL finalize_reprobus
-#endif
+        !$OMP END MASTER
+      ENDIF
+      IF (CPPKEY_REPROBUS) THEN
+        IF (type_trac == 'repr') CALL finalize_reprobus
+      END IF
 
       !$OMP MASTER
@@ -1044 +1039 @@
       !$OMP BARRIER
 
-         IF (ok_dynzon) THEN
-
-          CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
-                ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
-
-          ENDIF !ok_dynzon
-
-          IF (ok_dyn_ave) THEN
-             CALL writedynav_loc(itau,vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-          ENDIF
+      IF (ok_dynzon) THEN
+
+        CALL bilan_dyn_loc(2, dtvr * iperiod, dtvr * day_step * periodav, &
+                ps, masse, pk, pbaru, pbarv, teta, phi, ucov, vcov, q)
+
+      ENDIF !ok_dynzon
+
+      IF (ok_dyn_ave) THEN
+        CALL writedynav_loc(itau, vcov, &
+                ucov, teta, pk, phi, q, masse, ps, phis)
+      ENDIF
 
     ENDIF
@@ -1073 +1068 @@
         !$OMP BARRIER
 
-         IF (ok_dyn_ins) THEN
-             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
-                   masse,ps,phis)
-         endif
+        IF (ok_dyn_ins) THEN
+          CALL writehist_loc(itau, vcov, ucov, teta, pk, phi, q, &
+                  masse, ps, phis)
+        endif
 
         IF (ok_dyn_xios) THEN
@@ -1167 +1162 @@
         !$OMP END MASTER
 
-          IF (ANY(type_trac == ['inca', 'inco'])) THEN
-            CALL finalize_inca
-            ! switching back to LMDZDYN context
-            !$OMP MASTER
-            IF (ok_dyn_xios) THEN
-              CALL xios_set_current_context(dyn3d_ctx_handle)
-            ENDIF
-            !$OMP END MASTER
+        IF (ANY(type_trac == ['inca', 'inco'])) THEN
+          CALL finalize_inca
+          ! switching back to LMDZDYN context
+          !$OMP MASTER
+          IF (ok_dyn_xios) THEN
+            CALL xios_set_current_context(dyn3d_ctx_handle)
           ENDIF
-#ifdef REPROBUS
-             IF (type_trac == 'repr') CALL finalize_reprobus
-#endif
+          !$OMP END MASTER
+        ENDIF
+        IF (CPPKEY_REPROBUS) THEN
+          IF (type_trac == 'repr') CALL finalize_reprobus
+        END IF
 
         !$OMP MASTER
@@ -1200 +1195 @@
         ENDIF
 
-          ! Ehouarn: re-compute geopotential for outputs
-!$OMP BARRIER
-!$OMP MASTER
-          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-!$OMP END MASTER
-!$OMP BARRIER
-
-           IF (ok_dynzon) THEN
-           CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
-                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
-           ENDIF
-
-           IF (ok_dyn_ave) THEN
-             CALL writedynav_loc(itau,vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-           ENDIF
-
-      ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
-
-      IF(MOD(itau, iecri)==0) THEN
-
+        ! Ehouarn: re-compute geopotential for outputs
         !$OMP BARRIER
         !$OMP MASTER
@@ -1227 +1202 @@
         !$OMP BARRIER
 
-
-          IF (ok_dyn_ins) THEN
-             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
-                   masse,ps,phis)
-          endif ! of if (ok_dyn_ins)
+        IF (ok_dynzon) THEN
+          CALL bilan_dyn_loc(2, dtvr * iperiod, dtvr * day_step * periodav, &
+                  ps, masse, pk, pbaru, pbarv, teta, phi, ucov, vcov, q)
+        ENDIF
+
+        IF (ok_dyn_ave) THEN
+          CALL writedynav_loc(itau, vcov, &
+                  ucov, teta, pk, phi, q, masse, ps, phis)
+        ENDIF
+
+      ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
+
+      IF(MOD(itau, iecri)==0) THEN
+
+        !$OMP BARRIER
+        !$OMP MASTER
+        CALL geopot_loc(ip1jmp1, teta, pk, pks, phis, phi)
+        !$OMP END MASTER
+        !$OMP BARRIER
+
+        IF (ok_dyn_ins) THEN
+          CALL writehist_loc(itau, vcov, ucov, teta, pk, phi, q, &
+                  masse, ps, phis)
+        endif ! of if (ok_dyn_ins)
 
         IF (ok_dyn_xios) THEN
@@ -1269 +1263 @@
   !$OMP END MASTER
 
-    IF (ANY(type_trac == ['inca', 'inco'])) THEN
-      CALL finalize_inca
-      ! switching back to LMDZDYN context
-      !$OMP MASTER
-      IF (ok_dyn_xios) THEN
-        CALL xios_set_current_context(dyn3d_ctx_handle)
-      ENDIF
-      !$OMP END MASTER
+  IF (ANY(type_trac == ['inca', 'inco'])) THEN
+    CALL finalize_inca
+    ! switching back to LMDZDYN context
+    !$OMP MASTER
+    IF (ok_dyn_xios) THEN
+      CALL xios_set_current_context(dyn3d_ctx_handle)
     ENDIF
-#ifdef REPROBUS
-  IF (type_trac == 'repr') CALL finalize_reprobus
-#endif
+    !$OMP END MASTER
+  ENDIF
+  IF (CPPKEY_REPROBUS) THEN
+    IF (type_trac == 'repr') CALL finalize_reprobus
+  END IF
 
   !$OMP MASTER