Changeset 5116 for LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90

Timestamp:

Jul 24, 2024, 2:54:37 PM (4 months ago)

Author:

abarral

Message:

rename modules properly lmdz_*
move ismin, ismax, minmax into new lmdz_libmath.f90
(lint) uppercase fortran keywords

File:

• LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90 (modified) (16 diffs)

LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90

@@ -42 +42 @@
     temp = kelvin
     pres = millibar * 100.0
-    !      write(*,*)'kelvin,millibar=',kelvin,millibar
-    !      write(*,*)'temp,pres=',temp,pres
+    !      WRITE(*,*)'kelvin,millibar=',kelvin,millibar
+    !      WRITE(*,*)'temp,pres=',temp,pres
 
     IF (temp <= rtt) THEN
@@ -642 +642 @@
     CALL getin('nudging_t', nudging_t)
 
-    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
-    write(lunout, *)' Configuration des parametres du gcm1D: '
-    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
-    write(lunout, *)' restart = ', restart
-    write(lunout, *)' forcing_type = ', forcing_type
-    write(lunout, *)' time_ini = ', time_ini
-    write(lunout, *)' rlat = ', xlat
-    write(lunout, *)' rlon = ', xlon
-    write(lunout, *)' airephy = ', airefi
-    write(lunout, *)' nat_surf = ', nat_surf
-    write(lunout, *)' tsurf = ', tsurf
-    write(lunout, *)' psurf = ', psurf
-    write(lunout, *)' zsurf = ', zsurf
-    write(lunout, *)' rugos = ', rugos
-    write(lunout, *)' snowmass=', snowmass
-    write(lunout, *)' wtsurf = ', wtsurf
-    write(lunout, *)' wqsurf = ', wqsurf
-    write(lunout, *)' albedo = ', albedo
-    write(lunout, *)' xagesno = ', xagesno
-    write(lunout, *)' restart_runoff = ', restart_runoff
-    write(lunout, *)' qsolinp = ', qsolinp
-    write(lunout, *)' zpicinp = ', zpicinp
-    write(lunout, *)' nudge_tsoil = ', nudge_tsoil
-    write(lunout, *)' isoil_nudge = ', isoil_nudge
-    write(lunout, *)' Tsoil_nudge = ', Tsoil_nudge
-    write(lunout, *)' tau_soil_nudge = ', tau_soil_nudge
-    write(lunout, *)' tadv =      ', tadv
-    write(lunout, *)' tadvv =     ', tadvv
-    write(lunout, *)' tadvh =     ', tadvh
-    write(lunout, *)' thadv =     ', thadv
-    write(lunout, *)' thadvv =    ', thadvv
-    write(lunout, *)' thadvh =    ', thadvh
-    write(lunout, *)' qadv =      ', qadv
-    write(lunout, *)' qadvv =     ', qadvv
-    write(lunout, *)' qadvh =     ', qadvh
-    write(lunout, *)' trad =      ', trad
-    write(lunout, *)' forc_omega = ', forc_omega
-    write(lunout, *)' forc_w     = ', forc_w
-    write(lunout, *)' forc_geo   = ', forc_geo
-    write(lunout, *)' forc_ustar = ', forc_ustar
-    write(lunout, *)' nudging_u  = ', nudging_u
-    write(lunout, *)' nudging_v  = ', nudging_v
-    write(lunout, *)' nudging_t  = ', nudging_t
-    write(lunout, *)' nudging_qv  = ', nudging_qv
+    WRITE(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
+    WRITE(lunout, *)' Configuration des parametres du gcm1D: '
+    WRITE(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
+    WRITE(lunout, *)' restart = ', restart
+    WRITE(lunout, *)' forcing_type = ', forcing_type
+    WRITE(lunout, *)' time_ini = ', time_ini
+    WRITE(lunout, *)' rlat = ', xlat
+    WRITE(lunout, *)' rlon = ', xlon
+    WRITE(lunout, *)' airephy = ', airefi
+    WRITE(lunout, *)' nat_surf = ', nat_surf
+    WRITE(lunout, *)' tsurf = ', tsurf
+    WRITE(lunout, *)' psurf = ', psurf
+    WRITE(lunout, *)' zsurf = ', zsurf
+    WRITE(lunout, *)' rugos = ', rugos
+    WRITE(lunout, *)' snowmass=', snowmass
+    WRITE(lunout, *)' wtsurf = ', wtsurf
+    WRITE(lunout, *)' wqsurf = ', wqsurf
+    WRITE(lunout, *)' albedo = ', albedo
+    WRITE(lunout, *)' xagesno = ', xagesno
+    WRITE(lunout, *)' restart_runoff = ', restart_runoff
+    WRITE(lunout, *)' qsolinp = ', qsolinp
+    WRITE(lunout, *)' zpicinp = ', zpicinp
+    WRITE(lunout, *)' nudge_tsoil = ', nudge_tsoil
+    WRITE(lunout, *)' isoil_nudge = ', isoil_nudge
+    WRITE(lunout, *)' Tsoil_nudge = ', Tsoil_nudge
+    WRITE(lunout, *)' tau_soil_nudge = ', tau_soil_nudge
+    WRITE(lunout, *)' tadv =      ', tadv
+    WRITE(lunout, *)' tadvv =     ', tadvv
+    WRITE(lunout, *)' tadvh =     ', tadvh
+    WRITE(lunout, *)' thadv =     ', thadv
+    WRITE(lunout, *)' thadvv =    ', thadvv
+    WRITE(lunout, *)' thadvh =    ', thadvh
+    WRITE(lunout, *)' qadv =      ', qadv
+    WRITE(lunout, *)' qadvv =     ', qadvv
+    WRITE(lunout, *)' qadvh =     ', qadvh
+    WRITE(lunout, *)' trad =      ', trad
+    WRITE(lunout, *)' forc_omega = ', forc_omega
+    WRITE(lunout, *)' forc_w     = ', forc_w
+    WRITE(lunout, *)' forc_geo   = ', forc_geo
+    WRITE(lunout, *)' forc_ustar = ', forc_ustar
+    WRITE(lunout, *)' nudging_u  = ', nudging_u
+    WRITE(lunout, *)' nudging_v  = ', nudging_v
+    WRITE(lunout, *)' nudging_t  = ', nudging_t
+    WRITE(lunout, *)' nudging_qv  = ', nudging_qv
     IF (forcing_type ==40) THEN
-      write(lunout, *) '--- Forcing type GCSS Old --- with:'
-      write(lunout, *)'imp_fcg', imp_fcg_gcssold
-      write(lunout, *)'ts_fcg', ts_fcg_gcssold
-      write(lunout, *)'tp_fcg', Tp_fcg_gcssold
-      write(lunout, *)'tp_ini', Tp_ini_gcssold
-      write(lunout, *)'xturb_fcg', xTurb_fcg_gcssold
+      WRITE(lunout, *) '--- Forcing type GCSS Old --- with:'
+      WRITE(lunout, *)'imp_fcg', imp_fcg_gcssold
+      WRITE(lunout, *)'ts_fcg', ts_fcg_gcssold
+      WRITE(lunout, *)'tp_fcg', Tp_fcg_gcssold
+      WRITE(lunout, *)'tp_ini', Tp_ini_gcssold
+      WRITE(lunout, *)'xturb_fcg', xTurb_fcg_gcssold
     ENDIF
 
-    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
-    write(lunout, *)
+    WRITE(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
+    WRITE(lunout, *)
 
   END SUBROUTINE conf_unicol
@@ -729 +729 @@
     CHARACTER*(*) fichnom
     !Al1 plev tronque pour .nc mais plev(klev+1):=0
-    real :: plev(klon, klev + 1), play (klon, klev), phi(klon, klev)
-    real :: presnivs(klon, klev)
-    real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
-    real :: q(klon, klev, nqtot), omega2(klon, klev)
-    !      real :: ug(klev),vg(klev),fcoriolis
-    real :: phis(klon)
+    REAL :: plev(klon, klev + 1), play (klon, klev), phi(klon, klev)
+    REAL :: presnivs(klon, klev)
+    REAL :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
+    REAL :: q(klon, klev, nqtot), omega2(klon, klev)
+    !      REAL :: ug(klev),vg(klev),fcoriolis
+    REAL :: phis(klon)
 
     !   Variables locales pour NetCDF:
@@ -751 +751 @@
     !!      nmq(2)="cond"
     !!      do iq=3,nqtot
-    !!        write(nmq(iq),'("tra",i1)') iq-2
+    !!        WRITE(nmq(iq),'("tra",i1)') iq-2
     !!      enddo
     DO iq = 1, nqtot
@@ -862 +862 @@
     CHARACTER*(*) fichnom
     !Al1 plev tronque pour .nc mais plev(klev+1):=0
-    real :: plev(klon, klev), play (klon, klev), phi(klon, klev)
-    real :: presnivs(klon, klev)
-    real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
-    real :: q(klon, klev, nqtot)
-    real :: omega2(klon, klev), rho(klon, klev + 1)
-    !      real :: ug(klev),vg(klev),fcoriolis
-    real :: phis(klon)
+    REAL :: plev(klon, klev), play (klon, klev), phi(klon, klev)
+    REAL :: presnivs(klon, klev)
+    REAL :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
+    REAL :: q(klon, klev, nqtot)
+    REAL :: omega2(klon, klev), rho(klon, klev + 1)
+    !      REAL :: ug(klev),vg(klev),fcoriolis
+    REAL :: phis(klon)
 
     !   Variables locales pour NetCDF:
@@ -1031 +1031 @@
     !         ierr    = severity of situation ( = 0 normal )
 
-    character(len = *) modname
+    CHARACTER(LEN = *) modname
     integer ierr
-    character(len = *) message
-
-    write(*, *) 'in abort_gcm'
+    CHARACTER(LEN = *) message
+
+    WRITE(*, *) 'in abort_gcm'
     CALL histclo
     !     CALL histclo(2)
@@ -1041 +1041 @@
     !     CALL histclo(4)
     !     CALL histclo(5)
-    write(*, *) 'out of histclo'
-    write(*, *) 'Stopping in ', modname
-    write(*, *) 'Reason = ', message
+    WRITE(*, *) 'out of histclo'
+    WRITE(*, *) 'Stopping in ', modname
+    WRITE(*, *) 'Reason = ', message
     CALL getin_dump
 
-    if (ierr == 0) then
-      write(*, *) 'Everything is cool'
+    if (ierr == 0) THEN
+      WRITE(*, *) 'Everything is cool'
     else
-      write(*, *) 'Houston, we have a problem ', ierr
+      WRITE(*, *) 'Houston, we have a problem ', ierr
     endif
     STOP
@@ -1296 +1296 @@
 
     do l = 1, llm
-      if(l==1) then
+      IF(l==1) THEN
         !si omgup pour la couche 1, alors tendance nulle
         omgdown = max(omega(2), 0.0)
@@ -1308 +1308 @@
         d_v_va(l) = -omgdown * (v(l) - v(l + 1)) / (play(l) - play(l + 1))
 
-      elseif(l==llm) then
+      elseif(l==llm) THEN
         omgup = min(omega(l), 0.0)
         alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
@@ -1415 +1415 @@
     d_t_va(llm) = -omup * dtdp(llm)!+omup*cor(llm)
 
-    !      if(abs(rlat(1))>10.) then
+    !      IF(abs(rlat(1))>10.) THEN
     !     Calculate the tendency due agestrophic motions
     !      du_age = fcoriolis*(v-vg)
@@ -1715 +1715 @@
     do l = 1, llm
 
-      if (play(l)>=plev_prof_cas(nlev_cas)) then
-
+      if (play(l)>=plev_prof_cas(nlev_cas)) THEN
         mxcalc = l
         !        print *,'debut interp2, mxcalc=',mxcalc
@@ -1722 +1721 @@
         k2 = 0
 
-        if (play(l)<=plev_prof_cas(1)) then
-
+        if (play(l)<=plev_prof_cas(1)) THEN
           do k = 1, nlev_cas - 1
-            if (play(l)<=plev_prof_cas(k).and. play(l)>plev_prof_cas(k + 1)) then
+            if (play(l)<=plev_prof_cas(k).and. play(l)>plev_prof_cas(k + 1)) THEN
               k1 = k
               k2 = k + 1
@@ -1731 +1729 @@
           enddo
 
-          if (k1==0 .or. k2==0) then
-            write(*, *) 'PB! k1, k2 = ', k1, k2
-            write(*, *) 'l,play(l) = ', l, play(l) / 100
+          if (k1==0 .or. k2==0) THEN
+            WRITE(*, *) 'PB! k1, k2 = ', k1, k2
+            WRITE(*, *) 'l,play(l) = ', l, play(l) / 100
             do k = 1, nlev_cas - 1
-              write(*, *) 'k,plev_prof_cas(k) = ', k, plev_prof_cas(k) / 100
+              WRITE(*, *) 'k,plev_prof_cas(k) = ', k, plev_prof_cas(k) / 100
             enddo
           endif
@@ -1742 +1740 @@
           t_mod_cas(l) = t_prof_cas(k2) - frac * (t_prof_cas(k2) - t_prof_cas(k1))
           theta_mod_cas(l) = th_prof_cas(k2) - frac * (th_prof_cas(k2) - th_prof_cas(k1))
-          if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
+          IF(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
           thv_mod_cas(l) = thv_prof_cas(k2) - frac * (thv_prof_cas(k2) - thv_prof_cas(k1))
           thl_mod_cas(l) = thl_prof_cas(k2) - frac * (thl_prof_cas(k2) - thl_prof_cas(k1))
@@ -1780 +1778 @@
           t_mod_cas(l) = frac1 * t_prof_cas(k1) - frac2 * t_prof_cas(k2)
           theta_mod_cas(l) = frac1 * th_prof_cas(k1) - frac2 * th_prof_cas(k2)
-          if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
+          IF(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
           thv_mod_cas(l) = frac1 * thv_prof_cas(k1) - frac2 * thv_prof_cas(k2)
           thl_mod_cas(l) = frac1 * thl_prof_cas(k1) - frac2 * thl_prof_cas(k2)
@@ -1851 +1849 @@
     enddo ! l
 
-    return
+    RETURN
   end