source: LMDZ.3.3/trunk/libf/dyn3d/lectfluxnc.F @ 185

      SUBROUTINE lectfluxnc0(irec,massem,pbarun,pbarvn,wn,tetan,phin,
     s     nrec,avant,airefi,phisfi,
     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
     s     yu1,yv1,ftsol,pctsrf,
     s     frac_impa,frac_nucl,phis)

      IMPLICIT NONE

#include "dimensions.h"
#include "paramet.h"
#include "logic.h"
#include "comvert.h"
#include "comconst.h"
#include "comgeom2.h"

#include "tracstoke.h"

      integer irec,nrec,i,j

      integer klon,ig,l
      parameter (klon=iim*(jjm-1)+2)
      INTEGER nbsrf
      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille

c Convection
      real*4 zmfd(klon,llm),zde_d(klon,llm),zen_d(klon,llm)
      real*4 zmfu(klon,llm),zde_u(klon,llm),zen_u(klon,llm)
      real*4 mfd(klon,llm),de_d(klon,llm),en_d(klon,llm)
      real*4 mfu(klon,llm),de_u(klon,llm),en_u(klon,llm)
        real*4 t(klon,llm)
      real zdtvr
        
        real*4 airedy(iip1,jjp1)
      real*4 rlonu_dy(iip1,jjp1),rlonv_dy(iip1,jjm),
     . rlatu_dy(iip1,jjp1),rlatv_dy(iip1,jjm)

      real*4 coefkz(klon,llm)
      real*4 frac_impa(klon,llm),frac_nucl(klon,llm)
      real*4 yu1(klon), yv1(klon)
      real*4 ftsol(klon,nbsrf),pctsrf(klon,nbsrf)

      logical avant

      real massefi(klon,llm)

c   Flux masse
      real*4 massem(iip1,jjp1,llm),tetan(iip1,jjp1,llm)
      real*4 pbarun(iip1,jjp1,llm),pbarvn(iip1,jjm,llm)
      real*4 pbarvst(iip1,jjp1,llm)
      real*4 wn(iip1,jjp1,llm),phin(iip1,jjp1,llm)
      real*4 phis(iip1,jjp1)

      real*4 airefi(klon),phisfi(klon)

      real zcontrole(klon),zmass,tmpdyn(iip1,jjp1),zflux

      real ziadvtrac,ziadvtrac2,zrec2
      integer zim,zjm,zlm,zklon,zklev,zrec

      real zpi

      zpi=2.*asin(1.)


c==================================================================
c   Si le numero du record est 0 alors: INITIALISATION
c==================================================================
c
      print*,'ENTREE DANS LECTFLUXNC'
        print*,'IREC=',IREC

      if(irec.eq.0) then

        print*,'IREC==',0

C test         call inigeom

c==================================================================
c   ouverture des fichiers
c==================================================================
        
        CALL read_dstoke(0,zdtvr,ziadvtrac,ziadvtrac2)
        
        CALL read_fstoke0(0,
     .  zrec,zim,zjm,zlm,
     .   rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,airedy,phis,
     .   massem,pbarun,pbarvn,wn,tetan,phin)
c 
        if(physic)then  
        CALL read_pstoke0(0,
     .   zrec,zklon,zklev,airefi,phisfi,
     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefkz,
     .   frac_impa,frac_nucl,yu1,yv1,ftsol,pctsrf)
        endif
        
        dtvr=zdtvr      
        nrec=zrec
        print*,'nrec=',nrec
        
        print*, 'Lecture de defstoke.nc'
        print*, 'Ds lectfluxnc dtvr = ', dtvr
        print*, 'Ds lectfluxnc istdyn= ',ziadvtrac
        print*, 'Ds lectfluxnc istphy= ',ziadvtrac2

      istdyn=ziadvtrac
      istphy=ziadvtrac2
        
c       pause

c==================================================================
c   Fin des initialisations
      else ! irec=0
c==================================================================


c-----------------------------------------------------------------------
c   Lecture des fichiers fluxmass et  physique:
c   -----------------------------------------------------

         CALL read_fstoke0(irec,
     .   zrec,zim,zjm,zlm,
     .   rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,airedy,phis,
     .   massem,pbarun,pbarvn,wn,tetan,phin)
        
        write(*,*) 'lectfluxnc aps read_fstoke irec',irec
        if(physic)then
        CALL read_pstoke0(irec,
     .   zrec,zklon,zklev,airefi,phisfi,
     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefkz,
     .   frac_impa,frac_nucl,yu1,yv1,ftsol,pctsrf)
        
        write(*,*) 'lectfluxnc aps read_pstoke irec',irec
        
        if (avant) then
c Simu directe
       do l=1,llm
          do ig=1,klon
             zmfu(ig,l)=mfu(ig,l)
             zmfd(ig,l)=mfd(ig,l)
             zde_u(ig,l)=de_u(ig,l)
             zen_u(ig,l)=en_u(ig,l)
             zde_d(ig,l)=de_d(ig,l)
             zen_d(ig,l)=en_d(ig,l)
          enddo
       enddo
      else
c   Simu retro
       do l=1,llm
          do ig=1,klon
             zmfd(ig,l)=-mfu(ig,l)
             zmfu(ig,l)=-mfd(ig,l)
             zen_d(ig,l)=de_u(ig,l)
             zde_d(ig,l)=en_u(ig,l)
             zen_u(ig,l)=de_d(ig,l)
             zde_u(ig,l)=en_d(ig,l)
          enddo
       enddo
      endif

c-----------------------------------------------------------------------
c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
c-----------------------------------------------------------------------

      print*,'Ap redec irec'
        write(*,*) 'dtphys = ', dtphys

         call gr_dyn_fi(llm,iip1,jjp1,klon,massem,massefi)

         do ig=1,klon
            zcontrole(ig)=1.
         enddo
c   zmass=(max(massem(ig,l),massem(ig,l-1))/airefi(ig)
         do l=2,llm
            do ig=1,klon
               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
               if(zflux.gt.0.9*zmass) then
                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
               endif
            enddo
         enddo

         do ig=1,klon
            if(zcontrole(ig).lt.0.99999) then
               print*,'ATTENTION !!! on reduit les flux de masse '
               print*,'convectifs au point ig=',ig
            endif
         enddo
        
        write(*,*) 'lectfluxnc avt gr_fi_dyn'

         call gr_fi_dyn(1,klon,iip1,jjp1,zcontrole,tmpdyn)
        
        write(*,*) 'lectfluxnc aps gr_fi_dyn'
        
         do l=1,llm
            do ig=1,klon
               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
            enddo
         enddo
         endif
        
        write(*,*) 'lectfluxnc fin de boucle if'

      endif ! irec=0

      RETURN
      END