*=*=*=*= calfis.html =*=*=*=*
SUBROUTINE calfis

SUBROUTINE calfis


      SUBROUTINE calfis(nq, lafin, jour, heure,
     $            pucov,pvcov,ph,pq,ppext,ppks,pphis,pphi,
     $            pducov,pdvcov,pdh,pdq,pw,
     $            pdufi,pdvfi,pdhfi,pdqfi,pdpsfi,unsfpnew)
      IMPLICIT NONE
c
c     Auteurs :  ....    F. Hourdin,  P.Le Van  .....
c
c=======================================================================
c
c   1. rearangement des tableaux et transformation
c      variables dynamiques  >  variables physiques
c   2. calcul des termes physiques
c   3. retransformation des tendances physiques en tendances dynamiques
c
c   remarques:
c   ----------
c
c    - les vent sont donnes dans la physique par leurs composantes
c      naturelles.
c    - la variable thermodynamique de la physique est une variable
c      intensive :  Cp * T * (Ps/P)**kappa
c      pour la dynamique on prend   Cp * T / P**kappa
c    - les deux seules variables dependant de la geometrie necessaires
c      pour la physique sont la latitude pour le rayonnement et
c      l'aire de la maille quand on veut integrer une grandeur
c      horizontalement.
c    - les points de la physique sont les points scalaires de la
c      la dynamique; numerotation:
c          1 pour le pole nord
c          (jjm-1)*iim pour l'interiuer du domaine
c          ngridmx pour le pole sud
c      ---> ngridmx=2+(jjm-1)*iim
c
c     Input :
c     -------
c       pucov           covariant zonal velocity
c       pvcov           covariant meridional velocity
c       ph              potential temperature
c       ppext           extensive surface pressure
c       ppks
c       pts             surface temperature  (K)
c       callrad         clef d'appel au rayonnement
c
c    Output :
c    --------
c        pdufi          tendency for the natural zonal velocity (ms-1)
c        pdvfi          tendency for the natural meridional velocity
c        pdhfi          tendency for the potential temperature
c        pdtsfi         tendency for the surface temperature
c
c        pdtrad         radiative tendencies  \  both input
c        pfluxrad       radiative fluxes      /  and output
c
c=======================================================================
c
c-----------------------------------------------------------------------
c
c    0.  Declarations :
c    ------------------

#include "dimensions.h"
#include "paramet.h"
#include "temps.h"

      INTEGER ngridmx,nq
      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )

#include "comconst.h"
#include "comvert.h"
#include "comgeom2.h"
#include "control.h"
#include "serre.h"

c    Arguments :
c    -----------
      LOGICAL  lafin
      INTEGER jour
      REAL heure

      REAL pvcov(iip1,jjm,llm)
      REAL pucov(iip1,jjp1,llm)
      REAL ph(iip1,jjp1,llm)
      REAL pq(iip1,jjp1,llm,nqmx)
      REAL pphis(iip1,jjp1)
      REAL pphi(iip1,jjp1,llm)
c
      REAL pdvcov(iip1,jjm,llm)
      REAL pducov(iip1,jjp1,llm)
      REAL pdh(iip1,jjp1,llm)
      REAL pdq(iip1,jjp1,llm,nqmx)
c
      REAL pw(iip1,jjp1,llm)
c
      REAL ppext(iip1,jjp1)
      REAL ppks(iip1,jjp1)
c
      REAL pdvfi(iip1,jjm,llm)
      REAL pdufi(iip1,jjp1,llm)
      REAL pdhfi(iip1,jjp1,llm)
      REAL pdqfi(iip1,jjp1,llm,nqmx)
      REAL pdpsfi(iip1,jjp1), unsfpnew(iip1,jjp1)

c    Local variables :
c    -----------------
      REAL unspext(iip1,jjp1)

      INTEGER i,j,l,ig0,ig,iq
      REAL zpsrf(ngridmx)
      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
      REAL zphi(ngridmx,llm),zphis(ngridmx)
c
      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
      REAL ztfi(ngridmx,llm), zqfi(ngridmx,llm,nqmx)
c
      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,nqmx)
c
      REAL pvervel(ngridmx,llm)
c
      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqmx)
      REAL zdpsrf(ngridmx)
c
      REAL zsin(iim),zcos(iim),z1(iim)
      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)

      REAL pextairen(iim), pextaires(iim), unspextn, unspexts
      REAL unspexqn, unspexqs
c

      EXTERNAL gr_dyn_fi,gr_fi_dyn
      EXTERNAL physiq,multipl
      REAL SSUM
      EXTERNAL SSUM

      REAL latfi(ngridmx),lonfi(ngridmx)
      REAL airefi(ngridmx), slscp

      LOGICAL firstcal, debut
      DATA firstcal/.true./
      SAVE firstcal,debut
c
c-----------------------------------------------------------------------
c
c    1. Initialisations :
c    --------------------
c

      IF (ngridmx.NE.2+(jjm-1)*iim) THEN
         PRINT*,'STOP dans calfis'
         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
         PRINT*,'  ngridmx  jjm   iim   '
         PRINT*,ngridmx,jjm,iim
         STOP
      ENDIF

c-----------------------------------------------------------------------
c   latitude, longitude et aires des mailles pour la physique:
c   ----------------------------------------------------------

cc     ... P.Le Van  ( 6/02/95 )  ...
c
      IF ( firstcal )  THEN
          debut = .TRUE.
      ELSE
          debut = .FALSE.
      ENDIF

c
      IF (firstcal) THEN
         latfi(1)=rlatu(1)
         lonfi(1)=0.
         DO j=2,jjm
            DO i=1,iim
               latfi((j-2)*iim+1+i)=rlatu(j)
               lonfi((j-2)*iim+1+i)=rlonv(i)
       	    ENDDO
         ENDDO
         latfi(ngridmx) = rlatu(jjp1)
         lonfi(ngridmx) = 0.
         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
c
         PRINT*,'WARNING!!! vitesse verticale nulle dans la physique'
c
         CALL inifis( ngridmx,llm,daysec,day_ini,dtphys ,
     $               latfi,lonfi,airefi,rad,g,r,cpp       )
       ENDIF
c

      DO j = 1, jjp1
         DO i = 1, iip1
           unspext(i,j) = 1./ ppext(i,j)
         ENDDO
      ENDDO

c
c     ........    P. Le Van  ( ajout le  17/04/96  )  ......
c
      IF( alphax.NE.0. )   THEN

        DO i = 1, iim
         pextairen( i  )   =  unsfpnew(i, 1  ) * aire( i,  1   )
         pextaires( i  )   =  unsfpnew(i,jjp1) * aire( i, jjp1 )
        ENDDO
         unspexqn          =   SSUM( iim,pextairen,1 ) / apoln
         unspexqs          =   SSUM( iim,pextaires,1 ) / apols
c
        DO i = 1, iim
         pextairen( i  )   =  unspext(i, 1  ) * aire( i,  1   )
         pextaires( i  )   =  unspext(i,jjp1) * aire( i, jjp1 )
        ENDDO
         unspextn          =   SSUM( iim,pextairen,1 ) / apoln
         unspexts          =   SSUM( iim,pextaires,1 ) / apols
      ELSE

         unspexqn          =  unsfpnew( 1 ,  1   )
         unspexqs          =  unsfpnew( 1 , jjp1 )
         unspextn          =  unspext ( 1 ,  1   )
         unspexts          =  unspext ( 1,  jjp1 )

      ENDIF
c
c-----------------------------------------------------------------------
c   40. transformation des variables dynamiques en variables physiques:
c   ---------------------------------------------------------------

c   41. pressions au sol (en mb)
c   -------------------------

      zpsrf(   1   ) = SSUM( iim,ppext(1,  1 ),1 ) / apoln
      zpsrf(ngridmx) = SSUM( iim,ppext(1,jjp1),1 ) / apols

      ig0=2
      DO j=2,jjm
         CALL multipl(iim,ppext(1,j),unsaire(1,j),zpsrf(ig0))
         ig0=ig0+iim
      ENDDO

c
c   42. temperature (en K)
c   ---------------------

      DO l=1,llm
         slscp = s(l) / cpp
         ztfi(1,l) = ph(1,1,l) * ppks(1,1) * slscp
         pcvgt(1,l)= pdh(1,1,l)* ppks(1,1) * slscp * unspextn



         ig0=2
         DO j=2,jjm
            DO i = 1, iim
               ztfi(ig0,l)  = ph(i,j,l) * ppks(i,j)* slscp
               pcvgt(ig0,l) = pdh(i,j,l)* ppks(i,j)* slscp
     *                            * unspext(i,j)
               ig0 = ig0 + 1
            ENDDO
         ENDDO

         ztfi(ig0,l) = ph(1,jjp1,l) * ppks(1,jjp1) * slscp
         pcvgt(ig0,l)= pdh(1,jjp1,l)* ppks(1,jjp1) * slscp* unspexts

      ENDDO

c   42.bis humidite specifique (en kg/kg)
c   -------------------------------------
c
c    .....   unsfpnew = 1./ (Filtre inverse de pext )   ........
c
      DO iq=1,nqmx
         DO l=1,llm
            zqfi(1,l,iq) = pq( 1,1,l,iq)
            pcvgq(1,l,iq)= pdq(1,1,l,iq) * unspexqn

            ig0=2
            DO j=2,jjm
               DO i = 1, iim
                   zqfi(ig0,l,iq) = pq ( i,j,l,iq )
                  pcvgq(ig0,l,iq) = pdq( i,j,l,iq ) * unsfpnew(i,j)
                  ig0 = ig0 + 1
               ENDDO
            ENDDO

             zqfi(ig0,l,iq) =  pq(1,jjp1,l,iq)
            pcvgq(ig0,l,iq) = pdq(1,jjp1,l,iq) * unspexqs
         ENDDO
      ENDDO

c   Geopotentiel calcule par rapport a la surface locale:
c   -----------------------------------------------------

      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
      DO l=1,llm
       DO ig=1,ngridmx
         zphi(ig,l)=zphi(ig,l)-zphis(ig)
       ENDDO
      ENDDO

c   42.ter vitesse vertical (m/s)
c   ---------------------

c     DO l=1,llm
c        pvervel(1,l)=pw(1,1,l)
c        ig0=2
c        DO j=2,jjm
c           DO i = 1, iim
c              pvervel(ig0,l) = pw(i,j,l)
c              ig0 = ig0 + 1
c           ENDDO
c        ENDDO
c        pvervel(ig0,l)=pw(1,jjp1,l)
c     ENDDO
      CALL initial0(ngridmx*llm,pvervel)
c
c   43. pression intercouches:
c   --------------------------

      DO l=1,llmp1
         DO j=1,ngridmx
            zplev(j,l) = zpsrf(j)*sig(l)
         ENDDO
      ENDDO
      DO l=1,llm
       DO ig=1,ngridmx
          zplay(ig,l)=zpsrf(ig)*sig_s(l)
       ENDDO
      ENDDO


c   45. champ u:
c   ------------

      DO 450 l=1,llm

         DO 455 j=2,jjm
            ig0=1+(j-2)*iim
            zufi(ig0+1,l)= 0.5 *
     $      ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
            pcvgu(ig0+1,l)= 0.5 *
     $      ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
            DO 457 i=2,iim
               zufi(ig0+i,l)= 0.5 *
     $         ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
               pcvgu(ig0+i,l)= 0.5 *
     $         ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
457         CONTINUE
455      CONTINUE

450   CONTINUE


c   46.champ v:
c   -----------

      DO l=1,llm
         DO j=2,jjm
            ig0=1+(j-2)*iim
            DO i=1,iim
               zvfi(ig0+i,l)= 0.5 *
     $         ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
               pcvgv(ig0+i,l)= 0.5 *
     $         ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
            ENDDO
         ENDDO
      ENDDO


c   47. champs de vents aux pole nord
c   ------------------------------
c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]

      DO l=1,llm

         z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
         DO i=2,iim
            z1(i)=(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
         ENDDO

         DO i=1,iim
            zcos(i)=COS(rlonv(i))*z1(i)
            zcosbis(i)=COS(rlonv(i))*z1bis(i)
            zsin(i)=SIN(rlonv(i))*z1(i)
            zsinbis(i)=SIN(rlonv(i))*z1bis(i)
         ENDDO

         zufi(1,l)=SSUM(iim,zcos,1)/pi
         pcvgu(1,l)=SSUM(iim,zcosbis,1)/pi
         zvfi(1,l)=SSUM(iim,zsin,1)/pi
         pcvgv(1,l)=SSUM(iim,zsinbis,1)/pi

      ENDDO


c   48. champs de vents aux pole sud:
c   ---------------------------------
c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]

      DO l=1,llm

         z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
         DO i=2,iim
            z1(i)=(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
       ENDDO

         DO i=1,iim
            zcos(i)   = COS(rlonv(i))*z1(i)
            zcosbis(i)= COS(rlonv(i))*z1bis(i)
            zsin(i)   = SIN(rlonv(i))*z1(i)
            zsinbis(i)= SIN(rlonv(i))*z1bis(i)
       ENDDO

         zufi ( ngridmx,l)= SSUM(iim,zcos,1)   /pi
         pcvgu( ngridmx,l)= SSUM(iim,zcosbis,1)/pi
         zvfi ( ngridmx,l)= SSUM(iim,zsin,1)   /pi
         pcvgv( ngridmx,l)= SSUM(iim,zsinbis,1)/pi

      ENDDO

c-----------------------------------------------------------------------
c   Appel de la physique:
c   ---------------------

      CALL physiq ( ecritphy,ngridmx,llm,nq,
     e           debut, lafin,
     e           jour, heure,dtphys,
     e           zplev,zplay,zphi,
     e           zufi, zvfi,ztfi, zqfi,
     e           pcvgu,pcvgv,pcvgt, pcvgq,
     e           pvervel,
C - sorties
     s           zdufi, zdvfi, zdtfi, zdqfi,zdpsrf )

500   CONTINUE

c-----------------------------------------------------------------------
c   transformation des tendances physiques en tendances dynamiques:
c   ---------------------------------------------------------------

c  tendance sur la pression extensive:
c  -----------------------------------

      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
      CALL multipl(ip1jmp1,aire,pdpsfi,pdpsfi)

c   62. enthalpie potentielle
c   ---------------------

      DO l=1,llm

         slscp = s(l) / cpp

         DO i=1,iip1
           pdhfi(i, 1  ,l)  = zdtfi(1,l)/ppks(1,1) / slscp
           pdhfi(i,jjp1,l)  = zdtfi(ngridmx,l)/ppks(1,jjp1)/ slscp
         ENDDO

         DO j=2,jjm
            ig0=1+(j-2)*iim
            DO i=1,iim
               pdhfi(i,j,l)= zdtfi(ig0+i,l)/ppks(i,j)/ slscp
            ENDDO
            pdhfi(iip1,j,l)= pdhfi(1,j,l)
         ENDDO

      ENDDO


c   62. humidite specifique
c   ---------------------

      DO iq=1,nqmx
         DO l=1,llm
            DO i=1,iip1
               pdqfi(i,1,l,iq)   = zdqfi(1,l,iq)
               pdqfi(i,jjp1,l,iq)= zdqfi(ngridmx,l,iq)
            ENDDO
            DO j=2,jjm
               ig0=1+(j-2)*iim
               DO i=1,iim
                pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
               ENDDO
                pdqfi(iip1,j,l,iq)= pdqfi(1,j,l,iq)
            ENDDO
         ENDDO
      ENDDO

c   65. champ u:
c   ------------

      DO l=1,llm

         DO i=1,iip1
            pdufi(i,1,l)=0.
            pdufi(i,jjp1,l)=0.
         ENDDO

         DO j=2,jjm
            ig0=1+(j-2)*iim
            DO i=1,iim-1
               pdufi(i,j,l)=
     $         0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
            ENDDO
            pdufi(iim,j,l)=
     $      0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
            pdufi(iip1,j,l)=pdufi(1,j,l)
         ENDDO

      ENDDO


c   67. champ v:
c   ------------

      DO l=1,llm

         DO j=2,jjm-1
            ig0=1+(j-2)*iim
            DO i=1,iim
               pdvfi(i,j,l)=
     $         0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
            ENDDO
            pdvfi(iip1,j,l)= pdvfi(1,j,l)
         ENDDO
      ENDDO


c   68. champ v pres des poles:
c   ---------------------------
c      v = U * cos(long) + V * SIN(long)

      DO l=1,llm

         DO i=1,iim
            pdvfi(i,1,l)=
     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
            pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i))
     $      +zdvfi(ngridmx,l)*SIN(rlonv(i))
            pdvfi(i,1,l)=
     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
            pdvfi(i,jjm,l)=
     $      0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
          ENDDO

         pdvfi(iip1,1,l)  = pdvfi(1,1,l)
         pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)

      ENDDO

c-----------------------------------------------------------------------

700   CONTINUE

      firstcal = .FALSE.

      RETURN
      END