Changeset 5103 for LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90

Timestamp:

Jul 23, 2024, 3:29:36 PM (8 weeks ago)

Author:

abarral

Message:

Handle CPP_INLANDSIS in lmdz_cppkeys_wrapper.F90
Remove obsolete key wrgrads_thermcell, _ADV_HALO, _ADV_HALLO, isminmax
Remove redundant uses of CPPKEY_INCA (thanks acozic)
Remove obsolete misc/write_field.F90
Remove unused ioipsl_* wrappers
Remove calls to WriteField_u with wrong signature
Convert .F -> .[fF]90
(lint) uppercase fortran operators
[note: 1d and iso still broken - working on it]

File:

• LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90 (modified) (39 diffs)

LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90

@@ -7 +7 @@
 CONTAINS
 
-      subroutine thermcell_main(itap,ngrid,nlay,ptimestep  &
+      SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep  &
                     ,pplay,pplev,pphi,debut  &
                     ,puwind,pvwind,ptemp,p_o,ptemp_env, po_env  &
@@ -185 +185 @@
    fm=0. ; entr=0. ; detr=0.
 
-      if (prt_level>=1) print*,'thermcell_main V4'
-
-       sorties=.true.
+      if (prt_level>=1) PRINT*,'thermcell_main V4'
+
+       sorties=.TRUE.
       IF(ngrid/=ngrid) THEN
          PRINT*
@@ -195 +195 @@
       ENDIF
 
-!print*,'thermcell_main debut'
+!PRINT*,'thermcell_main debut'
 !     write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)'
      do ig=1,ngrid
@@ -205 +205 @@
       if (prt_level>=20) then
        do ig=1,ngrid
-          print*,'th_main ig f0',ig,f0(ig)
+          PRINT*,'th_main ig f0',ig,f0(ig)
        enddo
       endif
@@ -238 +238 @@
         !    SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
         ! &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out)
-        ! contenu thermcell_env : call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
+        ! contenu thermcell_env : CALL thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
         ! contenu thermcell_env : do ll=1,nlay
         ! contenu thermcell_env :    do ig=1,ngrid
@@ -267 +267 @@
                  ztv(ig,l)=ztv(ig,l)*(1.+RETV*po_env(ig,l))
                  zthl(ig,l)=ptemp(ig,l)/zpspsk(ig,l)
-                 mask(ig,l)=.true.
+                 mask(ig,l)=.TRUE.
             enddo
         enddo
-        call thermcell_qsat(ngrid*nlay,mask,pplev,ptemp_env,p_o,zqsat)
+        CALL thermcell_qsat(ngrid*nlay,mask,pplev,ptemp_env,p_o,zqsat)
           
       endif
        
-      if (prt_level>=1) print*,'thermcell_main apres thermcell_env'
+      if (prt_level>=1) PRINT*,'thermcell_main apres thermcell_env'
 
 !------------------------------------------------------------------------
@@ -322 +322 @@
          masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
       enddo
-      if (prt_level>=1) print*,'thermcell_main apres initialisation'
+      if (prt_level>=1) PRINT*,'thermcell_main apres initialisation'
 
 !------------------------------------------------------------------
@@ -395 +395 @@
 !--------------------------------------------------------------------------------
 
-      if (prt_level>=1) print*,'avant thermcell_plume ',lev_out
+      if (prt_level>=1) PRINT*,'avant thermcell_plume ',lev_out
 
 !=====================================================================
@@ -412 +412 @@
 
       if (iflag_thermals_ed<=9) then
-!         print*,'THERM NOUVELLE/NOUVELLE Arnaud'
+!         PRINT*,'THERM NOUVELLE/NOUVELLE Arnaud'
          CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,p_o,zl,rhobarz,&
       zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
@@ -420 +420 @@
 
       elseif (iflag_thermals_ed<=19) then
-!        print*,'THERM RIO et al 2010, version d Arnaud'
+!        PRINT*,'THERM RIO et al 2010, version d Arnaud'
          CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,p_o,zl,rhobarz,&
       zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
@@ -434 +434 @@
       endif
 
-      if (prt_level>=1) print*,'apres thermcell_plume ',lev_out
-
-      call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
-      call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
-
-      if (prt_level>=1) print*,'thermcell_main apres thermcell_plume'
+      if (prt_level>=1) PRINT*,'apres thermcell_plume ',lev_out
+
+      CALL test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
+      CALL test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
+
+      if (prt_level>=1) PRINT*,'thermcell_main apres thermcell_plume'
       if (prt_level>=10) then
          write(lunout1,*) 'Dans thermcell_main 2'
@@ -461 +461 @@
          wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l))
       enddo
-!     print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax
-
-
-
-      call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
-      call test_ltherm(ngrid,nlay,pplay,lmin ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
-      call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
-      call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
-
-      if (prt_level>=1) print*,'thermcell_main apres thermcell_height'
+!     PRINT*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax
+
+
+
+      CALL test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
+      CALL test_ltherm(ngrid,nlay,pplay,lmin ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
+      CALL test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
+      CALL test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
+
+      if (prt_level>=1) PRINT*,'thermcell_main apres thermcell_height'
 
 !-------------------------------------------------------------------------------
@@ -481 +481 @@
 
  
-call test_ltherm(ngrid,nlay,pplay,lmin,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
-call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
-
-      if (prt_level>=1) print*,'thermcell_main apres thermcell_dry'
+CALL test_ltherm(ngrid,nlay,pplay,lmin,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
+CALL test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
+
+      if (prt_level>=1) PRINT*,'thermcell_main apres thermcell_dry'
       if (prt_level>=10) then
          write(lunout1,*) 'Dans thermcell_main 1b'
@@ -521 +521 @@
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-      if(prt_level>=1)print*,'thermcell_closure apres thermcell_closure'
+      if(prt_level>=1)PRINT*,'thermcell_closure apres thermcell_closure'
 
       if (tau_thermals>1.) then
@@ -546 +546 @@
 !IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
 
-      if (prt_level>=1) print*,'thermcell_main apres thermcell_flux'
-      call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
-      call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
+      if (prt_level>=1) PRINT*,'thermcell_main apres thermcell_flux'
+      CALL test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
+      CALL test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
 
 !------------------------------------------------------------------
@@ -588 +588 @@
 !------------------------------------------------------------------
       IF (iflag_thermals_down > 0) THEN
-        if (debut) print*,'WARNING !!! routine thermcell_down en cours de developpement'
+        if (debut) PRINT*,'WARNING !!! routine thermcell_down en cours de developpement'
         entrdn=fact_thermals_down*detr0
         detrdn=fact_thermals_down*entr0 
@@ -605 +605 @@
            enddo
         enddo
-        call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
+        CALL thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
                       zthl,zdthladj,zta,lev_out)
 
@@ -613 +613 @@
            enddo
         enddo
-        call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
+        CALL thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
                      z_o,pdoadj,z_oa,lev_out)
 
@@ -625 +625 @@
             enddo
           enddo
-          call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
+          CALL thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
                      xtpo_tmp,xtpdoadj_tmp,xtzo_tmp,lev_out)
           do ll=1,nlay
@@ -640 +640 @@
         DO ig=1,ngrid
           if (iso_eau.gt.0) then
-              call iso_verif_egalite(xtpo(iso_eau,ig,ll), &
+              CALL iso_verif_egalite(xtpo(iso_eau,ig,ll), &
             p_o(ig,ll),'thermcell_main 594')
-              call iso_verif_egalite(xtpdoadj(iso_eau,ig,ll), &
+              CALL iso_verif_egalite(xtpdoadj(iso_eau,ig,ll), &
             pdoadj(ig,ll),'thermcell_main 596')
           endif
           if (iso_HDO.gt.0) then
-              call iso_verif_aberrant_encadre(xtpo(iso_hdo,ig,ll) &
+              CALL iso_verif_aberrant_encadre(xtpo(iso_hdo,ig,ll) &
              /p_o(ig,ll),'thermcell_main 610')
           endif
@@ -666 +666 @@
 ! de pression horizontal avec l'environnement
 
-         call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+         CALL thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
 !    &    ,fraca*dvdq,zmax &
       ,fraca,zmax &
@@ -674 +674 @@
 
 ! calcul purement conservatif pour le transport de V
-         call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
+         CALL thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
       ,zu,pduadj,zua,lev_out)
-         call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
+         CALL thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
       ,zv,pdvadj,zva,lev_out)
 
@@ -682 +682 @@
     ENDIF
 
-!     print*,'13 OK convect8'
+!     PRINT*,'13 OK convect8'
       do l=1,nlay
          do ig=1,ngrid
@@ -689 +689 @@
       enddo
 
-      if (prt_level>=1) print*,'14 OK convect8'
+      if (prt_level>=1) PRINT*,'14 OK convect8'
 !------------------------------------------------------------------
 !   Calculs de diagnostiques pour les sorties
@@ -696 +696 @@
       
       if (sorties) then
-      if (prt_level>=1) print*,'14a OK convect8'
+      if (prt_level>=1) PRINT*,'14a OK convect8'
 ! calcul du niveau de condensation
 ! initialisation
@@ -731 +731 @@
 !      endif
 
-      if (prt_level>=1) print*,'14b OK convect8'
+      if (prt_level>=1) PRINT*,'14b OK convect8'
       do k=nlay,1,-1
          do ig=1,ngrid
@@ -740 +740 @@
          enddo
       enddo
-      if (prt_level>=1) print*,'14c OK convect8'
+      if (prt_level>=1) PRINT*,'14c OK convect8'
 !calcul des moments
 !initialisation
@@ -752 +752 @@
          enddo
       enddo      
-      if (prt_level>=1) print*,'14d OK convect8'
+      if (prt_level>=1) PRINT*,'14d OK convect8'
       if (prt_level>=10)write(lunout,*)                                &
        'WARNING thermcell_main wth2=0. si zw2 > 1.e-10'
@@ -783 +783 @@
 
 !calcul du ratqscdiff
-      if (prt_level>=1) print*,'14e OK convect8'
+      if (prt_level>=1) PRINT*,'14e OK convect8'
       var=0.
       vardiff=0.
@@ -796 +796 @@
       enddo
 
-      if (prt_level>=1) print*,'14f OK convect8'
+      if (prt_level>=1) PRINT*,'14f OK convect8'
 
       do l=1,nlay
@@ -808 +808 @@
       enddo
 
-      if (prt_level>=1) print*,'14g OK convect8'
+      if (prt_level>=1) PRINT*,'14g OK convect8'
          do l=1,nlay
             do ig=1,ngrid
@@ -816 +816 @@
       endif
 
-      if (prt_level>=1) print*,'thermcell_main FIN  OK'
-
-!print*,'thermcell_main fin'
+      if (prt_level>=1) PRINT*,'thermcell_main FIN  OK'
+
+!PRINT*,'thermcell_main fin'
  RETURN
-      end subroutine thermcell_main
+      END SUBROUTINE  thermcell_main
 
 !=============================================================================
 !/////////////////////////////////////////////////////////////////////////////
 !=============================================================================
-      subroutine test_ltherm(ngrid,nlay,pplay,long,ztv,p_o,ztva, &  ! in
+      SUBROUTINE test_ltherm(ngrid,nlay,pplay,long,ztv,p_o,ztva, &  ! in
               zqla,f_star,zw2,comment)                          ! in
 !=============================================================================
@@ -841 +841 @@
 
       if (prt_level>=1) THEN
-       print*,'WARNING !!! TEST ',comment
+       PRINT*,'WARNING !!! TEST ',comment
       endif
       return
@@ -849 +849 @@
 !IMtemp           if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
            if (prt_level>=10) then
-               print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
-               print*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
+               PRINT*,'WARNING ',comment,' au point ',i,' K= ',long(i)
+               PRINT*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
                do k=1,nlay
                   write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*p_o(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
@@ -863 +863 @@
 ! nrlmd le 10/04/2012   Transport de la TKE par le thermique moyen pour la fermeture en ALP 
 !                       On transporte pbl_tke pour donner therm_tke
-!                       Copie conforme de la subroutine DTKE dans physiq.F ecrite par Frederic Hourdin
+!                       Copie conforme de la SUBROUTINE DTKE dans physiq.F ecrite par Frederic Hourdin
 
 !=======================================================================
@@ -869 +869 @@
 !=======================================================================
 
-      subroutine thermcell_tke_transport( &
+      SUBROUTINE thermcell_tke_transport( &
        ngrid,nlay,ptimestep,fm0,entr0,rg,pplev,  &   ! in
        therm_tke_max)                                ! out
@@ -905 +905 @@
 
 
-      if (prt_level>=1) print*,'Q2 THERMCEL_DQ 0'
+      if (prt_level>=1) PRINT*,'Q2 THERMCEL_DQ 0'
 
 !   calcul du detrainement
@@ -946 +946 @@
             endif
             if (qa(ig,k)<0.) then
-!               print*,'qa<0!!!'
+!               PRINT*,'qa<0!!!'
             endif
             if (q(ig,k)<0.) then
-!               print*,'q<0!!!'
+!               PRINT*,'q<0!!!'
             endif
          enddo
@@ -960 +960 @@
             wqd(ig,k)=fm(ig,k)*q(ig,k)
             if (wqd(ig,k)<0.) then
-!               print*,'wqd<0!!!'
+!               PRINT*,'wqd<0!!!'
             endif
          enddo