*=*=*=*= gcm.html =*=*=*=*
PROGRAM gcm

PROGRAM gcm


      PROGRAM gcm
      IMPLICIT NONE

c      ......   Version  du 29/04/97    ..........
c=======================================================================
c
c
cccccccccccccccccccccccccccccccccccccccccccc
c
c       VERSION MARTIENNE de gcm.F
c
c                sans traceurs
c                avec sponge
c
cccccccccccccccccccccccccccccccccccccccccccc
c
c
c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
c   -------
c   Modif special traceur F.Forget 05/94
c
c   Objet:
c   ------
c
c   GCM LMD nouvelle grille
c
c=======================================================================

c   ...      modification de l'integration de q ( 26/04/94 )      ....
c   ....  Valeur moyenne de h , pks et de q  aux  poles , 8/04/96  .....
c   ...  Dans inigeom , nouveaux calculs pour les elongations  cu , cv
c        et possibilite d'appeler une fonction f(y)  a derivee tangente
c        hyperbolique a la  place de la fonction a derivee sinusoidale.
c   ...  Possibilite de choisir le shema de Van-leer pour l'advection de
c         q  , en faisant iadv = 3  dans   traceur  (29/04/97) .
c
c-----------------------------------------------------------------------
c   Declarations:
c   -------------

#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comdissnew.h"
#include "comvert.h"
#include "comgeom.h"
#include "logic.h"
#include "temps.h"
#include "control.h"
#include "ener.h"
#include "drsdef.h"
#include "description.h"
#include "serre.h"
#include "sponge.h"

      INTEGER*4  iday ! jour julien
      REAL       time ! Heure de la journee en fraction d'1 jour
      REAL zdtvr
      INTEGER nbetatmoy, nbetatdem,nbetat
      INTEGER ierr, ASLUN, cllun

c   variables dynamiques
      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
      REAL h(ip1jmp1,llm)                    ! temperature potentielle
      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
      REAL pext(ip1jmp1)                     ! pression extensive
      REAL ps(ip1jmp1)                       !
      REAL pks(ip1jmp1),pksf(ip1jmp1)        ! exner (f pour filtre)
      REAL phis(ip1jmp1)                     ! geopotentiel au sol
      real gdx(ip1jmp1)
      REAL phi(ip1jmp1,llm)                  ! geopotentiel
      REAL w(ip1jmp1,llm)                    ! vitesse verticale

c variables dynamiques intermediaire pour le transport
      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse

c   variables dynamiques au pas -1
      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
      REAL hm1(ip1jmp1,llm),pextm1(ip1jmp1)

c   tendances dynamiques
      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
      REAL dh(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1)

c   tendances de la dissipation
      REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
      REAL dhdis(ip1jmp1,llm)

c   tendances physiques
      REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
      REAL dhfi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1)

c   variables pour le fichier histoire
      REAL dtav      ! intervalle de temps elementaire

c     INTEGER iadv(nqmx) ! indice schema de transport pour le traceur iq

      INTEGER taphistd,taprstar,taphmoy,tapphys

      INTEGER itau,itaufinp1,iav

      EXTERNAL caldyn, traceur
      EXTERNAL dissip,geopot,iniconst,inifilr
      EXTERNAL integrd,lectba,SCOPY
      EXTERNAL iniav,writeavs,writedem,writehis
      EXTERNAL inigeom
      EXTERNAL exner_new,addit
      EXTERNAL defrun_new, test_period
      EXTERNAL vanleer
      REAL  SSUM
      REAL time_0 , finvpold(ip1jmp1), unsfpnew(ip1jmp1)

      LOGICAL startdrs,lafin
      INTEGER ij,l,nnn

      REAL hppn(iim),hpps(iim),hpn,hps
      REAL finpe(ip1jmp1)
c     LOGICAL first

c-----------------------------------------------------------------------
c   Initialisations:
c   ----------------

      startdrs = .TRUE.
      descript = 'Run GCM LMDZ'
      lafin    = .FALSE.

c-----------------------------------------------------------------------
c
c  ....  Choix  des shemas d'advection pour l'eau et les traceurs  ...
c  ...................................................................
c
c     iadv = 1    shema  transport type "humidite specifique LMD"
c     iadv = 2    shema   amont
c     iadv = 3    shema  Van-leer
c
c     dans le tableau q(ij,l,iq) , iq = 1  pour l'eau vapeur
c                                , iq = 2  pour l'eau liquide
c         et eventuellement      , iq = 3, nqmx pour les autres traceurs
c
c     iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
c
c     iadv( 1 ) = 3
c     iadv( 2 ) = 3
c
c     DO  iq = 1, nqmx
c      IF( iadv(iq).EQ.1 ) PRINT *,' Choix du shema humidite specifique'
c    * ,' pour le traceur no ', iq
c      IF( iadv(iq).EQ.2 ) PRINT *,' Choix du shema  amont',' pour le'
c    * ,' traceur no ', iq
c      IF( iadv(iq).EQ.3 ) PRINT *,' Choix du shema  Van-Leer ',' pour'
c    * ,'le traceur no ', iq
c      IF( iadv(iq).LE.0.OR.iadv(iq).GT.3 )   THEN
c      PRINT *,' Erreur dans le  choix de  iadv . Corriger et repasser
c    * . '
c        STOP
c      ENDIF
c     ENDDO
c
c     first = .TRUE.
c     DO  iq = 1, nqmx
c       IF( iadv(iq).EQ.3.AND.first ) THEN
c         numvanle = iq
c         first    = .FALSE.
c       ENDIF
c     ENDDO
c
c     DO  iq = 1, nqmx
c       IF( iadv(iq).NE.3.AND.iq.GT.numvanle )   THEN
c         PRINT *,' Il y a discontinuite dans le choix du shema de ',
c    *    'Van-leer pour les traceurs . Corriger et repasser . '
c          STOP
c       ENDIF
c       IF( iadv(iq).LT.1.OR.iadv(iq).GT.3 )    THEN
c         PRINT *,' Le choix de  iadv  est errone pour le traceur ',
c    *    iq
c        STOP
c       ENDIF
c     ENDDO
c
c-----------------------------------------------------------------------

      CALL lectba(startdrs,nqmx,vcov,ucov,h,q,pext,phis,time_0)
      CALL defrun_new( .FALSE. )
      print *,'iperiod iphysiq ',iperiod,iphysiq

c  on recalcule eventuellement le pas de temps

      IF(MOD(day_step,iperiod).NE.0)
     * STOP'Il faut choisir un nb de pas par jour multiple de iperiod'

      IF(MOD(day_step,iphysiq).NE.0)
     * STOP'Il faut choisir un nb de pas par jour multiple de iphysiq'

      zdtvr    = daysec/FLOAT(day_step)
        IF(dtvr.NE.zdtvr) THEN
         PRINT*,'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
        ENDIF

c  nombre d'etats dans les fichiers demarrage et histoire
      nbetatdem = nday / iecri
      nbetatmoy = nday / periodav + 1

      dtvr = zdtvr
      CALL iniconst
      CALL inigeom

      CALL inifilr

c   ......    P.Le Van    ( modif  le 29/04/97 )   .........
c
      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
     *                tetagdiv, tetagrot , tetatemp              )
c

      CALL exner_new( ip1jmp1, pext, .TRUE., pks, pksf )

c  numero de stockage pour les fichiers de redemarrage:

      taphistd = 10
      tapphys  = 12
      taprstar = 15
      taphmoy  = 20

c    ...  ouverture DRS des fichiers de stockage  ...

      IF(startdrs) THEN
         ierr = ASLUN(taphistd,'histoire.dic',
     .             taphistd+1,'histoire.dat',IDRS_CREATE)
      ELSE
         PRINT*,'Ouverture binaire',taphistd
         OPEN(taphistd,file='histoire',form='unformatted',
     .   status='new',iostat=ierr)
      ENDIF

      IF (ierr.NE.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier histoire (rdem)'
        WRITE(6,*)' ierr = ', ierr
        CALL EXIT(1)
      ENDIF

      IF(startdrs) THEN
         ierr = ASLUN(taprstar,'restart.dic',
     .             taprstar+1,'restart.dat',IDRS_CREATE)
      ELSE
         OPEN(taprstar,file='restart',form='unformatted',
     .         status='new',iostat=ierr   )
      ENDIF

      IF (ierr.NE.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier restart'
        WRITE(6,*)' ierr = ', ierr
        CALL EXIT(1)
      ENDIF

      ierr = ASLUN(taphmoy,'histmoy.dic',
     .             taphmoy+1,'histmoy.dat',IDRS_CREATE )
      IF (ierr.NE.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier restart'
        WRITE(6,*)' ierr = ', ierr
        CALL EXIT(1)
      ENDIF

      ierr = ASLUN(tapphys,'histphy.dic',
     .             tapphys+1,'histphy.dat',IDRS_CREATE)
      IF (ierr.NE.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier physique'
        WRITE(6,*)' ierr = ', ierr
        CALL EXIT(1)
      ENDIF

c-----------------------------------------------------------------------
c   temps de depart et de fin:
c   --------------------------

      itau = 0
      iday = day_ini+itau/day_step
      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
         IF(time.GT.1.) THEN
          time = time-1.
          iday = iday+1
         ENDIF
      itaufin   = nday*day_step
      itaufinp1 = itaufin +1

      day_end = day_ini + nday
      PRINT 300, itau,itaufin,day_ini,day_end

      CALL iniwrite(taphistd,startdrs,day_ini,phis)
      CALL iniwrite(tapphys,startdrs,day_ini,phis )
      CALL iniwrite(taprstar,startdrs,day_end,phis)

      ecripar = .TRUE.

      dtav = iperiod*dtvr/daysec
      CALL iniav(taphmoy,day_ini,0.,periodav,phis)

c-----------------------------------------------------------------------
c   Debut de l'integration temporelle:
c   ----------------------------------

   1  CONTINUE
c
      IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
         CALL  test_period ( ucov,vcov,h,q,pext,phis )
         PRINT *,' ----   Test_period   OK ! -----', itau
      ENDIF
      call groupeun(jjp1,llm,ucov,.true.)
      call groupeun(jjm,llm,vcov,.true.)
      call groupeun(jjp1,llm,h,.true.)
      call groupeun(jjp1,1,pext,.false.)

      CALL SCOPY( ijmllm ,vcov, 1, vcovm1 , 1 )
      CALL SCOPY( ijp1llm,ucov, 1, ucovm1 , 1 )
      CALL SCOPY( ijp1llm,   h, 1,  hm1   , 1 )
      CALL SCOPY( ip1jmp1,pext, 1,  pextm1, 1 )
cc  z.x.li    CALL SCOPY( ijp1llm*nqmx,q,1,qm1,1 )

      forward = .TRUE.
      leapf   = .FALSE.
      dt      =  dtvr

c   ...    P.Le Van .26/04/94  ....

      CALL SCOPY   ( ip1jmp1, pext, 1, finvpold,    1 )
      CALL filtreg ( finvpold ,jjp1, 1, -2,2, .TRUE., 1 )


   2  CONTINUE

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

c   date:
c   -----


c   gestion des appels de la physique et des dissipations:
c   ------------------------------------------------------
c
c   ...    P.Le Van  ( 6/02/95 )  ....

      apphys = .FALSE.
      statcl = .FALSE.
      conser = .FALSE.
      apdiss = .FALSE.
      IF( purmats ) THEN
         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward
     $                              .AND.   physic    ) apphys = .TRUE.
      ELSE
         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
         IF( MOD(itau+1,iphysiq).EQ.0. AND. physic    ) apphys = .TRUE.
      END IF

c-----------------------------------------------------------------------
c   calcul des tendances dynamiques:
c   --------------------------------

      CALL geopot  (ip1jmp1, h     , pks   , phis    , phi          )
c
          IF (conser) print*,'*********** jour julien = ',iday
c
      CALL caldyn
     $ (itau,ucov,vcov,h,pext,pks,pksf,phis,
     $  phi,conser,du,dv,dh,dp,w, pbaru,pbarv,
     $  time+iday-day_ini)

c-----------------------------------------------------------------------
c   calcul des tendances advection des traceurs (dont l'humidite)
c   -------------------------------------------------------------
c
c     IF( forward. OR . leapf )  THEN
c
c        iapp_tracvl = 5
c        CALL SCOPY   ( ip1jmp1, pext, 1, finpe,      1 )
c        CALL filtreg ( finpe ,jjp1, 1, -2,2, .TRUE., 1 )
c        CALL tracvl( 1,iapp_tracvl,nqmx,pbaru,pbarv,finpe,q)
c
c     ENDIF
c
c-----------------------------------------------------------------------
c   integrations dynamique et traceurs:
c   ----------------------------------

       CALL integrd (  2,vcovm1,ucovm1,hm1,pextm1   ,
     $   dv,du,dh,dq,dp,vcov,ucov,h,q,pext,phis,finvpold,unsfpnew  )

c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
c
c-----------------------------------------------------------------------
c   calcul des tendances physiques:
c   -------------------------------
c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
c
       IF( purmats )  THEN
          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
       ELSE
          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
       ENDIF
c
c
       IF( apphys )  THEN


      print*,'APPEL de la PHYSIQUE'
c
c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
c
           CALL exner_new( ip1jmp1, pext, .FALSE., pks, pksf )

           CALL calfis(   nqmx, lafin ,iday,time      ,
     $                ucov,vcov,h,q,pext,pks,phis,phi ,
     $        du,dv,dh,dq,w,dufi,dvfi,dhfi,dqfi,dpfi,unsfpnew )

c      ajout des tendances physiques:
c      ------------------------------
            CALL addfi( nqmx,dtphys, leapf, forward   ,
     $                  ucov, vcov, h , q   ,pext ,
     $                  dufi, dvfi, dhfi , dqfi ,dpfi   )
c
       ENDIF

            CALL exner_new( ip1jmp1, pext, .TRUE., pks, pksf )

c-----------------------------------------------------------------------
c
c
c   dissipation horizontale et verticale  des petites echelles:
c   ----------------------------------------------------------

      IF(apdiss) THEN

         IF(callsponge) THEN
           CALL sponge(ucov,vcov,h,pext,dtdiss,mode_sponge)
         ENDIF

         CALL dissip(vcov,ucov,h,dvdis,dudis,dhdis)

         CALL addit( ijp1llm,ucov ,dudis,ucov )
         CALL addit( ijmllm ,vcov ,dvdis,vcov )
         CALL addit( ijp1llm,  h  ,dhdis,  h  )


c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
c
      IF( alphax.NE. 0. ) THEN

        DO l  =  1, llm
          DO ij =  1,iim
           hppn(ij)  = aire(  ij    ) * h(  ij    ,l)
           hpps(ij)  = aire(ij+ip1jm) * h(ij+ip1jm,l)
          ENDDO
           hpn  = SSUM(iim,hppn,1)/apoln
           hps  = SSUM(iim,hpps,1)/apols

          DO ij = 1, iip1
           h(  ij    ,l) = hpn
           h(ij+ip1jm,l) = hps
          ENDDO
        ENDDO

      ENDIF

      END IF

c   ********************************************************************
c   ********************************************************************
c   .... fin de l'integration dynamique  et physique pour le pas itau ..
c   ********************************************************************
c   ********************************************************************

c   preparation du pas d'integration suivant  ......

      IF ( .NOT.purmats ) THEN
c       ........................................................
c       ..............  schema matsuno + leapfrog  ..............
c       ........................................................

            IF(forward. OR. leapf) THEN
              itau= itau + 1
              iday= day_ini+itau/day_step
              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
                IF(time.GT.1.) THEN
                  time = time-1.
                  iday = iday+1
                ENDIF
            ENDIF


            IF( itau. EQ. itaufinp1 )    STOP

c-----------------------------------------------------------------------
c   ecriture du fichier histoire moyenne:
c   -------------------------------------

            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
               IF(itau.EQ.itaufin) THEN
                  iav=1
               ELSE
                  iav=0
               ENDIF
               CALL writeavs( nqmx,dtav,time+iday-day_ini  ,
     .                       ucov,vcov,h,q,pext,iav        )
            ENDIF

c-----------------------------------------------------------------------
c   ecriture de la bande histoire:
c   ------------------------------

            IF( MOD(itau,iecri*day_step).EQ.0) THEN
               nbetat = nbetatdem
c
c   .........    P. Le Van  ( modif le 19/04/96 )  ...........
c
               CALL geopot(ip1jmp1,h,pks,phis,phi)
               CALL writehis(taphistd,nqmx,startdrs,time+iday-day_ini,
     .                  vcov,ucov,h,phi,q,pext,phis,nbetat  )
            ENDIF

            IF(itau.EQ.itaufin) THEN
               CALL writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q,
     .                        pext,phis, 1   )
               CLOSE(99)
c   ecriture binaire de l'etat final pour test 1+1=2
c              OPEN(99,file='champ_fin',form='unformatted',
c    .         status='unknown')
c              WRITE(99) ucov,vcov,h,pext,phis
c              CLOSE(99)
            ENDIF

c-----------------------------------------------------------------------
c   gestion de l'integration temporelle:
c   ------------------------------------

            IF( MOD(itau,iperiod).EQ.0 )    THEN
                    GO TO 1
            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN

                   IF( forward )  THEN
c      fin du pas forward et debut du pas backward

                      forward = .FALSE.
                        leapf = .FALSE.
                           GO TO 2

                   ELSE
c      fin du pas backward et debut du premier pas leapfrog

                        leapf =  .TRUE.
                        dt  =  2.*dtvr
                        GO TO 2
                   END IF
            ELSE

c      ......   pas leapfrog  .....

                 leapf = .TRUE.
                 dt  = 2.*dtvr
                 GO TO 2
            END IF

      ELSE

c       ........................................................
c       ..............       schema  matsuno        ...............
c       ........................................................
            IF( forward )  THEN

              itau =  itau + 1
              iday = day_ini+itau/day_step
              time =FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
                  IF(time.GT.1.) THEN
                   time = time-1.
                   iday = iday+1
                  ENDIF

               forward =  .FALSE.
                 IF( itau. EQ. itaufinp1 )     STOP
               GO TO 2

            ELSE

c   ##########    P. Le Van (  ajout  19/12/95  )   ############
c
            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
               IF(itau.EQ.itaufin) THEN
                  iav=1
               ELSE
                  iav=0
               ENDIF
               CALL writeavs( nqmx,dtav,time+iday-day_ini  ,
     .                       ucov,vcov,h,q,pext,iav        )
            ENDIF

             IF(MOD(itau,iecri*day_step).EQ.0) THEN
                nbetat = nbetatdem
c
c   .........    P. Le Van  ( modif le 19/04/96 )  ...........
c
                CALL geopot(ip1jmp1,h,pks,phis,phi)
                CALL writehis(taphistd,nqmx,startdrs,time+iday-day_ini,
     .                   vcov,ucov,h,phi,q,pext,phis,nbetat  )
               ENDIF
                 IF(itau.EQ.itaufin)
     .           CALL writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q
     .                          , pext,phis,1    )

                 forward = .TRUE.
                 GO TO  1

            ENDIF

      END IF
      ierr = cllun(taphistd)
      ierr = cllun(taprstar)
      ierr = cllun(taphmoy)


 300  FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x,  'c"est a dire du
     * jour'i7,3x'au jour'i7//)

      STOP
      END