Changeset 541 for LMDZ4


Ignore:
Timestamp:
Jun 22, 2004, 1:45:36 PM (20 years ago)
Author:
lmdzadmin
Message:

Convergence avec la version d'Olivia Coindreau incluant:

  • le offline
  • les thermiques
  • mellor & yamada dans la couche limite

LF

Location:
LMDZ4/trunk
Files:
6 added
24 edited

Legend:

Unmodified
Added
Removed

  • LMDZ4/trunk/libf/dyn3d/bilan_dyn.F

    r524 r541  
    22! $Header$
    33!
    4 c
    5 c $Header$
    6 c
    74      SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
    85     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)

  • LMDZ4/trunk/libf/dyn3d/conf_gcm.F

    r527 r541  
    574574      ENDIF
    575575c
     576!Config  Key  = offline
     577!Config  Desc = Nouvelle eau liquide
     578!Config  Def  = n
     579!Config  Help = Permet de mettre en route la
     580!Config         nouvelle parametrisation de l'eau liquide !
     581       offline = .FALSE.
     582       CALL getin('offline',offline)
     583
    576584
    577585      write(lunout,*)' #########################################'
    … …  
    615623      write(lunout,*)' tauxx = ', tauxx
    616624      write(lunout,*)' tauyy = ', tauyy
     625      write(lunout,*)' offline = ', offline
    617626
    618627      RETURN
    … …  
    720729       CALL getin('ysinus',ysinus)
    721730c
     731!Config  Key  = offline
     732!Config  Desc = Nouvelle eau liquide
     733!Config  Def  = n
     734!Config  Help = Permet de mettre en route la
     735!Config         nouvelle parametrisation de l'eau liquide !
     736       offline = .FALSE.
     737       CALL getin('offline',offline)
     738      write(lunout,*)' offline = ', offline
     739
    722740
    723741      write(lunout,*)' #########################################'
    … …  
    761779      write(lunout,*)' taux = ', taux
    762780      write(lunout,*)' tauy = ', tauy
     781      write(lunout,*)' offline = ', offline
    763782c
    764783      RETURN

  • LMDZ4/trunk/libf/dyn3d/control.h

    r524 r541  
    66
    77      COMMON/control/nday,day_step,
    8      $              iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq ,
    9      $              periodav,ecritphy,iecrimoy,dayref,anneeref,
    10      $              raz_date
     8     .              iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq ,
     9     .              periodav,ecritphy,iecrimoy,dayref,anneeref,
     10     .              raz_date,offline
    1111
    1212      INTEGER   nday,day_step,iperiod,iapp_tracvl,iconser,iecri,
    13      $          idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date
     13     .          idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date
    1414      REAL periodav, ecritphy
     15      logical offline
    1516
    1617c-----------------------------------------------------------------------

  • LMDZ4/trunk/libf/dyn3d/dynetat0.F

    r524 r541  
    106106      IF ( tab_cntrl(24).EQ.1. )  THEN
    107107        fxyhypb  = . TRUE .
    108         dzoomx   = tab_cntrl(25)
    109         dzoomy   = tab_cntrl(26)
    110         taux     = tab_cntrl(28)
    111         tauy     = tab_cntrl(29)
     108c        dzoomx   = tab_cntrl(25)
     109c        dzoomy   = tab_cntrl(26)
     110c        taux     = tab_cntrl(28)
     111c        tauy     = tab_cntrl(29)
    112112      ELSE
    113113        fxyhypb = . FALSE .

  • LMDZ4/trunk/libf/dyn3d/dynredem.F

    r524 r541  
    394394#include "comgeom.h"
    395395#include "advtrac.h"
     396#include "temps.h"
    396397
    397398      INTEGER nq, l
    … …  
    406407      INTEGER ierr
    407408      INTEGER iq
     409      INTEGER length
     410      PARAMETER (length = 100)
     411      REAL tab_cntrl(length) ! tableau des parametres du run
    408412      character*20 modname
    409413      character*80 abort_message
    … …  
    435439#endif
    436440      PRINT*, "Enregistrement pour ", nb, time
     441
     442c
     443c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
     444c  on passe dans dynredem0
     445      ierr = NF_INQ_VARID (nid, "controle", nvarid)
     446      IF (ierr .NE. NF_NOERR) THEN
     447         abort_message="dynredem1: Le champ <controle> est absent"
     448         ierr = 1
     449         CALL abort_gcm(modname,abort_message,ierr)
     450      ENDIF
     451#ifdef NC_DOUBLE
     452      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
     453#else
     454      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
     455#endif
     456       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     457#ifdef NC_DOUBLE
     458      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
     459#else
     460      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
     461#endif
    437462
    438463c  Ecriture des champs

  • LMDZ4/trunk/libf/dyn3d/gcm.F

    r524 r541  
    5656#include "com_io_dyn.h"
    5757#include "iniprint.h"
    58 
    59 c#include "tracstoke.h"
     58#include "tracstoke.h"
    6059
    6160
    … …  
    118117c-jld
    119118
    120 
    121       LOGICAL offline  ! Controle du stockage ds "fluxmass"
    122       PARAMETER (offline=.false.)
    123119
    124120      character*80 dynhist_file, dynhistave_file
    … …  
    368364#endif
    369365
     366c  Choix des frequences de stokage pour le offline
     367c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
     368c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
     369      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
     370      istphy=istdyn/iphysiq     
     371
     372
    370373c
    371374c-----------------------------------------------------------------------

  • LMDZ4/trunk/libf/dyn3d/leapfrog.F

    r524 r541  
    149149c-jld
    150150
    151       LOGICAL offline  ! Controle du stockage ds "fluxmass"
    152       PARAMETER (offline=.false.)
    153 
    154151      character*80 dynhist_file, dynhistave_file
    155152      character*20 modname
    … …  
    199196
    200197#ifdef CPP_IOIPSL
    201       if (ok_guide) then
     198      if (ok_guide.and.(itaufin-itau-1)*dtvr.gt.21600) then
    202199        call guide(itau,ucov,vcov,teta,q,masse,ps)
     200      else
     201        print*,'attention on ne guide pas les 6 dernieres heures'
    203202      endif
    204203#endif
    … …  
    289288
    290289#ifdef CPP_IOIPSL
    291 c           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
    292 c    .   time_step, itau)
     290           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
     291     .   dtvr, itau)
    293292#endif
    294293
    … …  
    486485
    487486            IF( itau. EQ. itaufinp1 ) then 
    488 c      write(79,*) 'ucov',ucov
    489 c      write(80,*) 'vcov',vcov
    490 c      write(81,*) 'teta',teta
    491 c      write(82,*) 'ps',ps
    492 c      write(83,*) 'q',q
    493 c      WRITE(85,*) 'q1 = ',q(:,:,1)
    494 c      WRITE(86,*) 'q3 = ',q(:,:,3)
     487       write(79,*) 'ucov',ucov
     488       write(80,*) 'vcov',vcov
     489       write(81,*) 'teta',teta
     490       write(82,*) 'ps',ps
     491       write(83,*) 'q',q
     492       WRITE(85,*) 'q1 = ',q(:,:,1)
     493       WRITE(86,*) 'q3 = ',q(:,:,3)
    495494
    496495              abort_message = 'Simulation finished'

  • LMDZ4/trunk/libf/dyn3d/wrgrads.F

    r524 r541  
    2929      writectl=.false.
    3030
    31 c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
     31      print*,if,iid(if),jid(if),ifd(if),jfd(if)
    3232      iii=iid(if)
    3333      iji=jid(if)
    … …  
    3838      lm=lmd(if)
    3939
    40 c      print*,'im,jm,lm,name,firsttime(if)'
    41 c      print*,im,jm,lm,name,firsttime(if)
     40      print*,'im,jm,lm,name,firsttime(if)'
     41      print*,im,jm,lm,name,firsttime(if)
    4242
    4343      if(firsttime(if)) then
    … …  
    8181      endif
    8282
    83 c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
    84 c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
     83      print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
     84      print*,ivar(if),nvar(if),var(ivar(if),if),writectl
    8585      do l=1,nl
    8686         irec(if)=irec(if)+1

  • LMDZ4/trunk/libf/phylmd/FCTTRE.inc

    r524 r541  
    1616!
    1717      FOEEW ( PTARG,PDELARG ) = EXP ( &
    18      &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) &
     18!    &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-TEST_RTT) &
     19     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-273.16) &
    1920     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
    2021!
    … …  
    3132     &           + 25.21935 * EXP( - 2999.924 / ptarg))
    3233!
    33       dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg &
     34!      dqsats(ptarg,pqsarg) = TEST_RLVTT/TEST_RCPD*pqsarg * (3.56654/ptarg &
     35      dqsats(ptarg,pqsarg) = 0.2500800E+07/0.1004709E+04*pqsarg * (3.56654/ptarg &
    3436     &                     +2484.896*LOG(10.)/ptarg**2 &
    3537     &                     -0.00320991*LOG(10.))
    36       dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)* &
     38!     dqsatl(ptarg,pqsarg) = TEST_RLVTT/TEST_RCPD*pqsarg*LOG(10.)* &
     39      dqsatl(ptarg,pqsarg) = 0.2500800E+07/0.1004709E+04*pqsarg*LOG(10.)* &
    3740     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg &
    3841     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg) &

  • LMDZ4/trunk/libf/phylmd/clmain.F

    r524 r541  
    1717     .                  d_t,d_q,d_u,d_v,d_ts,
    1818     .                  flux_t,flux_q,flux_u,flux_v,cdragh,cdragm,
     19     .                  q2,
    1920     .                  dflux_t,dflux_q,
    20 cIM cf JLD    .                  zcoefh,zu1,zv1, t2m, q2m, u10m, v10m)
    2121     .                  zcoefh,zu1,zv1, t2m, q2m, u10m, v10m,
    2222     .                  fqcalving,ffonte, run_off_lic_0)
    … …  
    8989#include "dimsoil.h"
    9090#include "iniprint.h"
     91#include "compbl.h"
    9192c
    9293      REAL dtime
    … …  
    183184cAA      REAL yflxsrf(klon,nbtr)
    184185c
    185       LOGICAL contreg
    186       PARAMETER (contreg=.TRUE.)
    187186c
    188187      LOGICAL ok_nonloc
    189188      PARAMETER (ok_nonloc=.FALSE.)
    190189      REAL ycoefm0(klon,klev), ycoefh0(klon,klev)
     190
     191      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
     192      real ykmm(klon,klev+1),ykmn(klon,klev+1)
     193      real ykmq(klon,klev+1)
     194      real yq2(klon,klev+1),q2(klon,klev+1,nbsrf)
     195      real q2diag(klon,klev+1)
     196      real yustar(klon),y_cd_m(klon),y_cd_h(klon)
     197
     198
     199
     200
     201
    191202c
    192203#include "YOMCST.h"
    … …  
    220231      LOGICAL first_appel
    221232      SAVE first_appel
    222       DATA first_appel/.false./
     233      DATA first_appel/.true./
    223234      LOGICAL debugindex
    224235      SAVE debugindex
    … …  
    254265      endif
    255266      IF (first_appel) THEN
    256           first_appel=.false.
     267!          first_appel=.false.
    257268!
    258269! initialisation sorties netcdf
    … …  
    479490c
    480491c
     492cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    481493c calculer Cdrag et les coefficients d'echange
     494cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     495
     496cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     497c  Calcul anciens du LMD. Effectues de toutes facons.
     498cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     499
    482500      CALL coefkz(nsrf, knon, ypaprs, ypplay,
    483501cIM 261103
    … …  
    487505     .            yqsurf,
    488506     .            ycoefm, ycoefh)
     507
    489508      CALL coefkz2(nsrf, knon, ypaprs, ypplay,yt,
    490509     .                  ycoefm0, ycoefh0)
     510      if (first_appel) then
     511        if (prt_level > 9) THEN
     512          WRITE(lunout,*)'Apres coefkz2 '
     513          WRITE(lunout,*)'nsrf,knon,yts,yrugos,yqsurf',
     514     .    nsrf,knon,yts,yrugos,yqsurf
     515          WRITE(lunout,*)'ypaprs(1,k),ypplay(1,k),yu,yv,yt'
     516          do k=1,klev
     517            WRITE(lunout,*)ypaprs(1,k),ypplay(1,k),
     518     .      yu(1,k),yv(1,k),yt(1,k)
     519          enddo
     520          do k=1,klev
     521            WRITE(lunout,*)ycoefm(1,k),ycoefh(1,k),
     522     .      ycoefm0(1,k),ycoefh0(1,k)
     523          enddo
     524        ENDIF
     525        first_appel=.false.
     526      endif
     527
    491528      DO k = 1, klev
    492529      DO i = 1, knon
    … …  
    495532      ENDDO
    496533      ENDDO
     534
    497535c
    498536cIM cf JLD : on seuille ycoefm et ycoefh
    … …  
    528566cIM: 261103
    529567
    530 c
     568
     569      IF (iflag_pbl.ge.3) then
     570
     571cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     572c MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
     573cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     574
     575         yzlay(1:knon,1)=
     576     .   RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1)))
     577     .   *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
     578         do k=2,klev
     579            yzlay(1:knon,k)=
     580     .      yzlay(1:knon,k-1)+RD*0.5*(yt(1:knon,k-1)+yt(1:knon,k))
     581     .      /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG
     582         enddo
     583         do k=1,klev
     584            yteta(1:knon,k)=
     585     .      yt(1:knon,k)*(ypaprs(1:knon,1)/ypplay(1:knon,k))**rkappa
     586     .      *(1.+0.61*yq(1:knon,k))
     587         enddo
     588         yzlev(1:knon,1)=0.
     589         yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
     590         do k=2,klev
     591            yzlev(1:knon,k)=0.5*(yzlay(1:knon,k)+yzlay(1:knon,k-1))
     592         enddo
     593         DO k = 1, klev+1
     594            DO j = 1, knon
     595               i = ni(j)
     596               yq2(j,k)=q2(i,k,nsrf)
     597            enddo
     598         enddo
     599
     600
     601c   Bug introduit volontairement pour converger avec les resultats
     602c  du papier sur les thermiques.
     603         if (1.eq.1) then
     604         y_cd_m(1:knon) = ycoefm(1:knon,1)
     605         y_cd_h(1:knon) = ycoefh(1:knon,1)
     606         else
     607         y_cd_h(1:knon) = ycoefm(1:knon,1)
     608         y_cd_m(1:knon) = ycoefh(1:knon,1)
     609         endif
     610         call ustarhb(knon,yu,yv,y_cd_m, yustar)
     611
     612        if (prt_level > 9) THEN
     613          WRITE(lunout,*)'USTAR = ',yustar
     614        ENDIF
     615
     616c   iflag_pbl peut etre utilise comme longuer de melange
     617
     618         if (iflag_pbl.ge.11) then
     619            call vdif_kcay(knon,dtime,rg,rd,ypaprs,yt
     620     s      ,yzlev,yzlay,yu,yv,yteta
     621     s      ,y_cd_m,yq2,q2diag,ykmm,ykmn,yustar,
     622     s      iflag_pbl)
     623         else
     624            call yamada4(knon,dtime,rg,rd,ypaprs,yt
     625     s      ,yzlev,yzlay,yu,yv,yteta
     626     s      ,y_cd_m,yq2,ykmm,ykmn,ykmq,yustar,
     627     s      iflag_pbl)
     628         endif
     629
     630         ycoefm(1:knon,1)=y_cd_m(1:knon)
     631         ycoefh(1:knon,1)=y_cd_h(1:knon)
     632         ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
     633         ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
     634
     635
     636      ENDIF
     637
     638cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    531639c calculer la diffusion des vitesses "u" et "v"
     640cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     641
    532642      CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yu,ypaprs,ypplay,ydelp,
    533643     s            y_d_u,y_flux_u)
    … …  
    545655c$$$      enddo
    546656
     657cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    547658c calculer la diffusion de "q" et de "h"
     659cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    548660      CALL clqh(dtime, itap, date0,jour, debut,lafin,
    549661     e          rlon, rlat, cufi, cvfi,
    … …  
    560672     s          pctsrf_new, yagesno,
    561673     s          y_d_t, y_d_q, y_d_ts, yz0_new,
    562 cIM cf JLD    s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q)
    563674     s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q,
    564675     s          y_fqcalving,y_ffonte,y_run_off_lic_0)
    … …  
    699810c
    700811        qairsol(j) = yqsurf(j)
    701 c$$$        IF (nsrf.EQ.1) THEN
    702 c$$$          qairsol(j) = yqsurf(j)
    703 c$$$        ELSE IF(nsrf.GT.1) THEN
    704 c$$$         zt = ts(i,nsrf)
    705 c$$$         IF (thermcep) THEN
    706 c$$$           zdelta = MAX(0.,SIGN(1.,RTT-zt))
    707 c$$$           zqs = R2ES * FOEEW(zt,zdelta) / ypplay(j,1)
    708 c$$$           zqs = MIN(0.5,zqs)
    709 c$$$           zcor = 1./(1.-RETV*zqs)
    710 c$$$           zqs = zqs*zcor
    711 c$$$         ELSE
    712 c$$$           IF (zt .LT. t_coup) THEN
    713 c$$$             zqs = qsats(zt) / ypplay(j,1)
    714 c$$$           ELSE
    715 c$$$             zqs = qsatl(zt) / ypplay(j,1)
    716 c$$$           ENDIF
    717 c$$$         ENDIF   
    718 c$$$         qairsol(j) = zqs
    719 c$$$        ENDIF   
    720812      ENDDO
    721813c
    … …  
    778870       ENDDO
    779871#endif
     872
     873      do j=1,knon
     874         do k=1,klev+1
     875         i=ni(j)
     876         q2(i,k,nsrf)=yq2(j,k)
     877         enddo
     878      enddo
     879c
     880
    78088199999 CONTINUE
    781882c
    … …  
    802903     s                pctsrf_new, agesno,
    803904     s                d_t, d_q, d_ts, z0_new,
    804 cIM cf JLD    s                flux_t, flux_q,dflux_s,dflux_l)
    805905     s                flux_t, flux_q,dflux_s,dflux_l,
    806906     s                fqcalving,ffonte,run_off_lic_0)
    … …  
    820920#include "indicesol.h"
    821921#include "dimsoil.h"
     922#include "iniprint.h"
    822923
    823924c Arguments:
    … …  
    9011002      REAL zdelz
    9021003c======================================================================
    903       logical contreg
    904       parameter (contreg=.true.)
     1004#include "compbl.h"
    9051005c======================================================================
    9061006c Rajout pour l'interface
    … …  
    9441044      ENDIF
    9451045C
    946       if (.not. contreg) then
    947         do k = 2, klev
    948           do i = 1, knon
    949             gamq(i,k) = 0.0
    950             gamt(i,k) = 0.0
    951           enddo
    952         enddo
    953       else
     1046C
     1047      if (iflag_pbl.eq.1) then
    9541048        do k = 3, klev
    9551049          do i = 1, knon
    … …  
    9611055          gamq(i,2) = 0.0
    9621056          gamt(i,2) = -2.5e-03
     1057        enddo
     1058      else
     1059        do k = 2, klev
     1060          do i = 1, knon
     1061            gamq(i,k) = 0.0
     1062            gamt(i,k) = 0.0
     1063          enddo
    9631064        enddo
    9641065      endif
    … …  
    10891190     s evap, fluxsens, fluxlat, dflux_l, dflux_s,             
    10901191     s tsol_rad, tsurf_new, alb_new, alblw, emis_new, z0_new,
    1091 cIM cf JLD    s pctsrf_new, agesno)
    10921192     s pctsrf_new, agesno,fqcalving,ffonte, run_off_lic_0)
    10931193
    … …  
    11621262#include "dimensions.h"
    11631263#include "dimphy.h"
     1264#include "iniprint.h"
    11641265      INTEGER knon
    11651266      REAL dtime
    … …  
    12881389#include "YOMCST.h"
    12891390#include "indicesol.h"
     1391#include "iniprint.h"
    12901392c
    12911393c Arguments:
    … …  
    13351437      LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
    13361438      PARAMETER (opt_ec=.FALSE.)
    1337       LOGICAL contreg ! utiliser le contre-gradient dans Ri
    1338       PARAMETER (contreg=.TRUE.)
     1439
     1440#include "compbl.h"
    13391441c
    13401442c Variables locales:
    … …  
    13791481c
    13801482      IF (appel1er) THEN
    1381          PRINT*, 'coefkz, opt_ec:', opt_ec
    1382          PRINT*, 'coefkz, richum:', richum
    1383          IF (richum) PRINT*, 'coefkz, ratqs:', ratqs
    1384          PRINT*, 'coefkz, isommet:', isommet
    1385          PRINT*, 'coefkz, tvirtu:', tvirtu
    1386          appel1er = .FALSE.
     1483        if (prt_level > 9) THEN
     1484          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
     1485          WRITE(lunout,*)'coefkz, richum:', richum
     1486          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
     1487          WRITE(lunout,*)'coefkz, isommet:', isommet
     1488          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
     1489          appel1er = .FALSE.
     1490        endif
    13871491      ENDIF
    13881492c
    … …  
    13991503      ENDDO
    14001504
    1401 c$$$      IF(nsrf.NE.1) THEN
    1402 c$$$      do i = 1, knon
    1403 c$$$        qsurf(i) = qsatl(ts(i))/paprs(i,1)
    1404 c$$$      enddo
    1405 c$$$      ENDIF
    1406 
    14071505c
    14081506c Prescrire la valeur de contre-gradient
    14091507c
    1410       IF (.NOT.contreg) THEN
    1411          DO k = 2, klev
    1412             gamt(k) = 0.0
    1413          ENDDO
    1414       ELSE
     1508      if (iflag_pbl.eq.1) then
    14151509         DO k = 3, klev
    14161510            gamt(k) = -1.0E-03
    14171511         ENDDO
    14181512         gamt(2) = -2.5E-03
     1513      else
     1514         DO k = 2, klev
     1515            gamt(k) = 0.0
     1516         ENDDO
    14191517      ENDIF
    14201518cIM cf JLD/ GKtest
    … …  
    14691567      ENDDO
    14701568
    1471       IF (check) THEN
    1472       PRINT*,' isommet=',isommet,' knon=',knon
    1473       ENDIF
    14741569
    14751570      DO k = 2, isommet
    … …  
    16081703#include "YOMCST.h"
    16091704#include "indicesol.h"
     1705#include "iniprint.h"
    16101706c
    16111707c Arguments:
    … …  
    17021798#include "YOMCST.h"
    17031799#include "indicesol.h"
     1800#include "iniprint.h"
    17041801      REAL tau_gl ! temps de relaxation pour la glace de mer
    17051802ccc      PARAMETER (tau_gl=86400.0*30.0)
    … …  
    17831880#include "dimphy.h"
    17841881#include "YOMCST.h"
     1882#include "iniprint.h"
    17851883c
    17861884c Arguments:

  • LMDZ4/trunk/libf/phylmd/conf_phys.F90

    r524 r541  
    99 &                     ratqsbas,ratqshaut,if_ebil, &
    1010 &                     ok_ade, ok_aie, &
    11  &                     bl95_b0, bl95_b1)
     11 &                     bl95_b0, bl95_b1,&
     12 &                     iflag_thermals,nsplit_thermals)
    1213
    1314   use IOIPSL
    … …  
    1920#include "YOMCST.inc"
    2021!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
    21 #include "clesphys.inc"
     22include "clesphys.inc"
     23include "compbl.h"
    2224!
    2325! Configuration de la "physique" de LMDZ a l'aide de la fonction
    … …  
    5153  real                 :: zzz
    5254
     55  integer :: iflag_thermals,nsplit_thermals
    5356!
    5457!
    … …  
    514517  ok_kzmin = .true.
    515518  call getin('ok_kzmin',ok_kzmin)
     519
     520!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     521! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
     522!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     523
     524!Config Key  = iflag_pbl
     525!Config Desc =
     526!Config Def  = 1
     527!Config Help =
     528!
     529  iflag_pbl = 1
     530  call getin('iflag_pbl',iflag_pbl)
     531!
     532!Config Key  = iflag_thermals
     533!Config Desc =
     534!Config Def  = 0
     535!Config Help =
     536!
     537  iflag_thermals = 0
     538  call getin('iflag_thermals',iflag_thermals)
     539!
     540!
     541!Config Key  = nsplit_thermals
     542!Config Desc =
     543!Config Def  = 1
     544!Config Help =
     545!
     546  nsplit_thermals = 1
     547  call getin('nsplit_thermals',nsplit_thermals)
     548
     549
    516550
    517551!
    … …  
    606640  write(numout,*)' lev_histday = ',lev_histday
    607641  write(numout,*)' lev_histmth = ',lev_histmth
     642  write(numout,*)' iflag_pbl = ', iflag_pbl
     643  write(numout,*)' iflag_thermals = ', iflag_thermals
    608644
    609645  return

  • LMDZ4/trunk/libf/phylmd/initphysto.F

    r524 r541  
    188188c coefh frac_impa,frac_nucl
    189189       
    190         call histdef(fileid, 'coefh', ' ', ' ',
    191      .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
    192      .             32, 'inst(X)', t_ops, t_wrt)
     190        call histdef(fileid, "coefh", " ", " ",
     191     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
     192     .             32, "inst(X)", t_ops, t_wrt)
     193
     194c abderrahmane le 16 09 02
     195        call histdef(fileid, "fm_th", " ", " ",
     196     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
     197     .             32, "inst(X)", t_ops, t_wrt)
     198
     199        call histdef(fileid, "en_th", " ", " ",
     200     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
     201     .             32, "inst(X)", t_ops, t_wrt)
     202c fin aj
    193203       
    194204        write(*,*) 'apres coefh ds initphysto' 
    … …  
    283293
    284294      call histend(fileid)
    285       if (ok_sync) call histsync(fileid)
     295c     if (ok_sync) call histsync(fileid)
     296      if (ok_sync) call histsync
    286297
    287298       

  • LMDZ4/trunk/libf/phylmd/initrrnpb.F

    r524 r541  
    7474      DO i = 1,klon
    7575        masktr(i,it) = 0.
    76 c       IF ( NINT(pctsrf(i,3)) .EQ. 1 ) masktr(i,it) = 1.
    77 c       fshtr(i,it) = s * masktr(i,it) * pctsrf(i,3)
    7876        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
    7977        fshtr(i,it) = s * masktr(i,it)

  • LMDZ4/trunk/libf/phylmd/oasis.F

    r524 r541  
    22! $Header$
    33!
    4 C $Id$
    54C****
    65C
    … …  
    4342#include "mpiclim.h"
    4443c
    45 #include "oasis.h"      ! contains the name of communication technique. Here
     44#include "oasis.h"     
     45                        ! contains the name of communication technique. Here
    4646                        ! cchan=CLIM only is possible.
    4747c                       ! ctype=MPI2
    … …  
    557557      END
    558558
     559      SUBROUTINE halte
     560      print *, 'Attention dans oasis.F, halte est non defini'
     561      RETURN
     562      END
     563
     564      SUBROUTINE locread
     565      print *, 'Attention dans oasis.F, locread est non defini'
     566      RETURN
     567      END
     568
     569      SUBROUTINE locwrite
     570      print *, 'Attention dans oasis.F, locwrite est non defini'
     571      RETURN
     572      END
     573
    559574      SUBROUTINE pipe_model_define
    560575      print*,'Attention dans oasis.F, pipe_model_define est non defini'
    … …  
    577592      END
    578593
     594      SUBROUTINE clim_stepi
     595      print *, 'Attention dans oasis.F, clim_stepi est non defini'
     596      RETURN
     597      END
     598
     599      SUBROUTINE clim_start
     600      print *, 'Attention dans oasis.F, clim_start est non defini'
     601      RETURN
     602      END
     603
     604      SUBROUTINE clim_import
     605      print *, 'Attention dans oasis.F, clim_import est non defini'
     606      RETURN
     607      END
     608
     609      SUBROUTINE clim_export
     610      print *, 'Attention dans oasis.F, clim_export est non defini'
     611      RETURN
     612      END
     613
     614      SUBROUTINE clim_init
     615      print *, 'Attention dans oasis.F, clim_init est non defini'
     616      RETURN
     617      END
     618
     619      SUBROUTINE clim_define
     620      print *, 'Attention dans oasis.F, clim_define est non defini'
     621      RETURN
     622      END
     623
     624      SUBROUTINE clim_quit
     625      print *, 'Attention dans oasis.F, clim_quit est non defini'
     626      RETURN
     627      END
     628
     629      SUBROUTINE svipc_write
     630      print *, 'Attention dans oasis.F, svipc_write est non defini'
     631      RETURN
     632      END
     633
     634      SUBROUTINE svipc_close
     635      print *, 'Attention dans oasis.F, svipc_close est non defini'
     636      RETURN
     637      END
     638
     639      SUBROUTINE svipc_read
     640      print *, 'Attention dans oasis.F, svipc_read est non defini'
     641      RETURN
     642      END
     643
    579644      SUBROUTINE quitcpl
    580645      print *, 'Attention dans oasis.F, quitcpl est non defini'

  • LMDZ4/trunk/libf/phylmd/phyetat0.F

    r524 r541  
    665665           ENDDO
    666666         ENDDO
    667 c          IF (nsrf.GT.99) THEN
    668 c            PRINT*, "Trop de sous-mailles"
    669 c            CALL abort
    670 c          ENDIF
    671 c          WRITE(str2,'(i2.2)') nsrf
    672 c          ierr = NF_INQ_VARID (nid, "ALBLW"//str2, nvarid)
    673 c           IF (ierr.NE.NF_NOERR) THEN
    674 c             PRINT*, "phyetat0: Le champ <ALBLW"//str2//"> est absent"
    675 c             CALL abort
    676 c          ENDIF
    677 c#ifdef NC_DOUBLE
    678 c           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alblw(1,nsrf))
    679 c#else
    680 c           ierr = NF_GET_VAR_REAL(nid, nvarid, alblw(1,nsrf))
    681 c#endif
    682 c          IF (ierr.NE.NF_NOERR) THEN
    683 c            PRINT*, "phyetat0: Lecture echouee pour <ALBLW"//str2//">"
    684 c            CALL abort
    685 c          ENDIF
    686 c          xmin = 1.0E+20
    687 c          xmax = -1.0E+20
    688 c          DO i = 1, klon
    689 c             xmin = MIN(alblw(i,nsrf),xmin)
    690 c             xmax = MAX(alblw(i,nsrf),xmax)
    691 c          ENDDO
    692 c          PRINT*,'Albedo du sol ALBLW**:', nsrf, xmin, xmax
    693 c        ENDDO
    694667      ELSE
    695668         PRINT*, 'phyetat0: Le champ <ALBLW> est present'

  • LMDZ4/trunk/libf/phylmd/phyredem.F

    r524 r541  
    33!
    44c
    5 cIM   SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire,
    65      SUBROUTINE phyredem (fichnom,dtime,radpas,
    76     .           rlat,rlon, pctsrf,tsol,tsoil,deltat,qsurf,qsol,snow,
    … …  
    3029      INTEGER radpas
    3130      REAL rlat(klon), rlon(klon)
    32 cIM   REAL co2_ppm
    33 cIM   REAL solaire
    3431      REAL tsol(klon,nbsrf)
    3532      REAL tsoil(klon,nsoilmx,nbsrf)

  • LMDZ4/trunk/libf/phylmd/physiq.F

    r524 r541  
    22! $Header$
    33!
    4 C
    5 c $Header$
    64c
    75      SUBROUTINE physiq (nlon,nlev,nqmax,
    … …  
    8886#include "advtrac.h"
    8987#include "iniprint.h"
     88#include "thermcell.h"
    9089c======================================================================
    9190      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
    … …  
    157156      PARAMETER (ok_region=.FALSE.)
    158157c======================================================================
     158c     pour phsystoke avec thermiques
     159      REAL fm_therm(klon,klev+1)
     160      REAL entr_therm(klon,klev)
     161      real q2(klon,klev+1,nbsrf)
     162      save q2
     163c======================================================================
    159164c
    160165      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
    … …  
    594599      REAL zxffonte(klon), zxfqcalving(klon)
    595600
    596       LOGICAL offline           ! Controle du stockage ds "physique"
    597       PARAMETER (offline=.false.)
    598       INTEGER physid
     601c$$$      LOGICAL offline           ! Controle du stockage ds "physique"
     602c$$$      PARAMETER (offline=.false.)
     603c$$$      INTEGER physid
    599604      REAL pfrac_impa(klon,klev)! Produits des coefs lessivage impaction
    600605      save pfrac_impa
    … …  
    807812      REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev)
    808813      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
     814      REAL d_u_ajs(klon,klev), d_v_ajs(klon,klev)
    809815      REAL d_t_eva(klon,klev),d_q_eva(klon,klev)
    810816      REAL rneb(klon,klev)
    … …  
    10341040     .                  iflag_cldcon,ratqsbas,ratqshaut, if_ebil,
    10351041     .                  ok_ade, ok_aie,
    1036      .                  bl95_b0, bl95_b1)
    1037 cIM  .                  , RI0)
     1042     .                  bl95_b0, bl95_b1,
     1043     .                  iflag_thermals,nsplit_thermals)
    10381044
    10391045c
    … …  
    10531059     .       run_off_lic_0)
    10541060
     1061c   ATTENTION : il faudra a terme relire q2 dans l'etat initial
     1062         q2(:,:,:)=1.e-8
    10551063c
    10561064         radpas = NINT( 86400./dtime/nbapp_rad)
    … …  
    15081516     s            d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts,
    15091517     s            fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,
     1518     s            q2,
    15101519     s            dsens, devap,
    15111520     s            ycoefh,yu1,yv1, t2m, q2m, u10m, v10m,
    … …  
    18501859c Appeler l'ajustement sec
    18511860c
    1852       CALL ajsec(paprs, pplay, t_seri, q_seri, d_t_ajs, d_q_ajs)
    1853       DO k = 1, klev
    1854       DO i = 1, klon
    1855          t_seri(i,k) = t_seri(i,k) + d_t_ajs(i,k)
    1856          q_seri(i,k) = q_seri(i,k) + d_q_ajs(i,k)
    1857       ENDDO
    1858       ENDDO
     1861c===================================================================
     1862c Convection seche (thermiques ou ajustement)
     1863c===================================================================
     1864c
     1865      d_t_ajs(:,:)=0.
     1866      d_u_ajs(:,:)=0.
     1867      d_v_ajs(:,:)=0.
     1868      d_q_ajs(:,:)=0.
     1869      fm_therm(:,:)=0.
     1870      entr_therm(:,:)=0.
     1871c
     1872      print*,'AVANT LA CONVECTION SECHE , iflag_thermals='
     1873     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
     1874      if(iflag_thermals.lt.0) then
     1875c  Rien
     1876c  ====
     1877         print*,'pas de convection'
     1878      else if(iflag_thermals.eq.0) then
     1879
     1880c  Ajustement sec
     1881c  ==============
     1882         print*,'ajsec'
     1883         CALL ajsec(paprs, pplay, t_seri,q_seri, d_t_ajs, d_q_ajs)
     1884         t_seri(:,:) = t_seri(:,:) + d_t_ajs(:,:)
     1885         q_seri(:,:) = q_seri(:,:) + d_q_ajs(:,:)
     1886      else
     1887c  Thermiques
     1888c  ==========
     1889         print*,'JUSTE AVANT , iflag_thermals='
     1890     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
     1891         call calltherm(pdtphys
     1892     s      ,pplay,paprs,pphi
     1893     s      ,u_seri,v_seri,t_seri,q_seri
     1894     s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
     1895     s      ,fm_therm,entr_therm)
     1896      endif
     1897c
     1898c===================================================================
    18591899c
    18601900      IF (if_ebil.ge.2) THEN
    … …  
    25732613     I                   u,v,t,paprs,pplay,
    25742614     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
    2575      I                   ycoefh,yu1,yv1,ftsol,pctsrf,rlat,
    2576      I                   frac_impa, frac_nucl,
     2615     I                   ycoefh,fm_therm,entr_therm,yu1,yv1,ftsol,
     2616     I                   pctsrf,rlat,frac_impa, frac_nucl,
    25772617     I                   rlon,presnivs,pphis,pphi,
    25782618     I                   albsol,
    … …  
    25892629      IF (offline) THEN
    25902630
     2631         print*,'Attention on met a 0 les thermiques pour phystoke'
    25912632         call phystokenc (
    25922633     I                   nlon,nlev,pdtphys,rlon,rlat,
    25932634     I                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
     2635     I                   fm_therm,entr_therm,
    25942636     I                   ycoefh,yu1,yv1,ftsol,pctsrf,
    25952637     I                   frac_impa, frac_nucl,

  • LMDZ4/trunk/libf/phylmd/phystokenc.F

    r524 r541  
    77     I                   nlon,nlev,pdtphys,rlon,rlat,
    88     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
     9     I                   pfm_therm,pentr_therm,
    910     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
    10      I                   pfrac_impa,pfrac_nucl,
     11     I                   frac_impa,frac_nucl,
    1112     I                   pphis,paire,dtime,itap)
    1213      USE ioipsl
    … …  
    4041      real pdtphys ! pas d'integration pour la physique (seconde)
    4142c
    42       integer physid, itap,ndex(1)
     43      integer physid, itap
     44      save physid
     45      integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
    4346
    4447c   convection:
    … …  
    5154      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
    5255      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
    53         REAL pt(klon,klev)
     56        real pt(klon,klev),t(klon,klev)
    5457c
    5558      REAL rlon(klon), rlat(klon), dtime
    … …  
    6265      REAL yv1(klon)
    6366      REAL yu1(klon),pphis(klon),paire(klon)
     67
     68c   Les Thermiques : (Abderr 25 11 02)
     69c   ---------------
     70      REAL pfm_therm(klon,klev+1)
     71        real fm_therm1(klon,klev)
     72      REAL pentr_therm(klon,klev)
     73      REAL entr_therm(klon,klev)
     74      REAL fm_therm(klon,klev)
    6475c
    6576c   Lessivage:
    6677c   ----------
    6778c
    68       REAL pfrac_impa(klon,klev)
    69       REAL pfrac_nucl(klon,klev)
     79      REAL frac_impa(klon,klev)
     80      REAL frac_nucl(klon,klev)
    7081c
    7182c Arguments necessaires pour les sources et puits de traceur
    … …  
    8495      REAL de_d(klon,klev) ! flux detraine dans le panache descendant
    8596      REAL coefh(klon,klev) ! flux detraine dans le panache descendant
    86         REAL t(klon,klev)
    87       REAL frac_impa(klon,klev)
    88       REAL frac_nucl(klon,klev)
    89       REAL rain(klon)
    9097
    9198      REAL pyu1(klon),pyv1(klon)
    … …  
    98105      integer iadvtr,irec
    99106      real zmin,zmax
    100 
     107      logical ok_sync
     108 
    101109      save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
     110        save fm_therm,entr_therm
    102111      save iadvtr,irec
    103       save frac_impa,frac_nucl,rain
    104112      save pyu1,pyv1,pftsol,ppsrf
    105113
    … …  
    109117c======================================================================
    110118
     119      ok_sync = .true.
     120        print*,'Dans phystokenc.F'
    111121      print*,'iadvtr= ',iadvtr
    112122      print*,'istphy= ',istphy
    … …  
    120130        write(*,*) 'apres initphysto ds phystokenc'
    121131
    122        ndex(1) = 0
    123          i=itap
    124          CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
    125          CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
    126 c
    127          i=itap
    128          CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
    129          CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
    130132       
    131133      ENDIF
    132134c
     135      ndex2d = 0
     136      ndex3d = 0
     137      i=itap
     138      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
     139      CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex2d)
     140c
     141      i=itap
     142      CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
     143      CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex2d)
     144
    133145      iadvtr=iadvtr+1
    134146c
    135 c
    136 c   reinitialisation des champs cumules
    137147      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
    138148        print*,'reinitialisation des champs cumules
    … …  
    140150         do k=1,klev
    141151            do i=1,klon
    142                frac_impa(i,k)=1.
    143                frac_nucl(i,k)=1.
    144152               mfu(i,k)=0.
    145153               mfd(i,k)=0.
    … …  
    149157               de_d(i,k)=0.
    150158               coefh(i,k)=0.
    151                 t(i,k)=0.
    152             enddo
    153          enddo
    154          do i=1,klon
    155             rain(i)=0.
     159                t(i,k)=0.
     160                fm_therm(i,k)=0.
     161               entr_therm(i,k)=0.
     162            enddo
     163         enddo
     164         do i=1,klon
    156165            pyv1(i)=0.
    157166            pyu1(i)=0.
    … …  
    169178      do k=1,klev
    170179         do i=1,klon
    171             frac_impa(i,k)=frac_impa(i,k)*pfrac_impa(i,k)
    172             frac_nucl(i,k)=frac_nucl(i,k)*pfrac_nucl(i,k)
     180            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
     181            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
     182            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
     183            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
     184            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
     185            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
     186            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
     187                t(i,k)=t(i,k)+pt(i,k)*pdtphys
     188       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
     189       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
     190         enddo
     191      enddo
     192         do i=1,klon
     193            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
     194            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
     195         end do
     196         do k=1,nbsrf
     197             do i=1,klon
     198               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
     199               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
     200            enddo
     201         enddo
     202
     203      dtcum=dtcum+pdtphys
     204
     205      IF(mod(iadvtr,istphy).eq.0) THEN
     206c
     207c   normalisation par le temps cumule
     208         do k=1,klev
     209            do i=1,klon
     210               mfu(i,k)=mfu(i,k)/dtcum
     211               mfd(i,k)=mfd(i,k)/dtcum
     212               en_u(i,k)=en_u(i,k)/dtcum
     213               de_u(i,k)=de_u(i,k)/dtcum
     214               en_d(i,k)=en_d(i,k)/dtcum
     215               de_d(i,k)=de_d(i,k)/dtcum
     216               coefh(i,k)=coefh(i,k)/dtcum
     217c Unitel a enlever
     218              t(i,k)=t(i,k)/dtcum       
     219               fm_therm(i,k)=fm_therm(i,k)/dtcum
     220               entr_therm(i,k)=entr_therm(i,k)/dtcum
     221            enddo
     222         enddo
     223         do i=1,klon
     224            pyv1(i)=pyv1(i)/dtcum
     225            pyu1(i)=pyu1(i)/dtcum
     226         end do
     227         do k=1,nbsrf
     228             do i=1,klon
     229               pftsol(i,k)=pftsol(i,k)/dtcum
     230               pftsol1(i) = pftsol(i,1)
     231               pftsol2(i) = pftsol(i,2)
     232               pftsol3(i) = pftsol(i,3)
     233               pftsol4(i) = pftsol(i,4)
     234
     235               ppsrf(i,k)=ppsrf(i,k)/dtcum
     236               ppsrf1(i) = ppsrf(i,1)
     237               ppsrf2(i) = ppsrf(i,2)
     238               ppsrf3(i) = ppsrf(i,3)
     239               ppsrf4(i) = ppsrf(i,4)
     240
     241            enddo
     242         enddo
     243c
     244c   ecriture des champs
     245c
     246         irec=irec+1
     247
     248ccccc
     249         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
     250         CALL histwrite(physid,"t",itap,zx_tmp_3d,
     251     .                                   iim*(jjm+1)*klev,ndex3d)
     252
     253         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
     254      CALL histwrite(physid,"mfu",itap,zx_tmp_3d,
     255     .                                   iim*(jjm+1)*klev,ndex3d)
     256        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
     257      CALL histwrite(physid,"mfd",itap,zx_tmp_3d,
     258     .                                   iim*(jjm+1)*klev,ndex3d)
     259        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
     260      CALL histwrite(physid,"en_u",itap,zx_tmp_3d,
     261     .                                   iim*(jjm+1)*klev,ndex3d)
     262        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
     263      CALL histwrite(physid,"de_u",itap,zx_tmp_3d,
     264     .                                   iim*(jjm+1)*klev,ndex3d)
     265        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
     266      CALL histwrite(physid,"en_d",itap,zx_tmp_3d,
     267     .                                   iim*(jjm+1)*klev,ndex3d)
     268        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)       
     269      CALL histwrite(physid,"de_d",itap,zx_tmp_3d,   
     270     .                                   iim*(jjm+1)*klev,ndex3d)
     271        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)         
     272      CALL histwrite(physid,"coefh",itap,zx_tmp_3d,   
     273     .                                   iim*(jjm+1)*klev,ndex3d)       
     274
     275c ajou...
     276        do k=1,klev
     277           do i=1,klon
     278         fm_therm1(i,k)=fm_therm(i,k)   
     279           enddo
     280        enddo
     281
     282      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)
     283      CALL histwrite(physid,"fm_th",itap,zx_tmp_3d,
     284     .                                 iim*(jjm+1)*klev,ndex3d)
     285c
     286      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)
     287      CALL histwrite(physid,"en_th",itap,zx_tmp_3d,
     288     .                                iim*(jjm+1)*klev,ndex3d)
     289cccc
     290       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
     291        CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d,
     292     .  iim*(jjm+1)*klev,ndex3d)
     293
     294        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
     295        CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d,
     296     .  iim*(jjm+1)*klev,ndex3d)
     297 
     298        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
     299      CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),
     300     .                                                ndex2d)
     301       
     302        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
     303      CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1)
     304     .                                                ,ndex2d)
     305       
     306        CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
     307      CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,
     308     .                                   iim*(jjm+1),ndex2d)
     309         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
     310      CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,
     311     .                                   iim*(jjm+1),ndex2d)
     312          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
     313      CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,
     314     .                                   iim*(jjm+1),ndex2d)
     315         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
     316      CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,
     317     .                                   iim*(jjm+1),ndex2d)
     318
     319        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
     320      CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,   
     321     .                                   iim*(jjm+1),ndex2d)
     322        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
     323      CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,
     324     .                                   iim*(jjm+1),ndex2d)
     325        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
     326      CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,
     327     .                                   iim*(jjm+1),ndex2d)
     328        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
     329      CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,
     330     .                                   iim*(jjm+1),ndex2d)
     331
     332      if (ok_sync) call histsync(physid)
     333c     if (ok_sync) call histsync
     334       
     335c
     336cAA Test sur la valeur des coefficients de lessivage
     337c
     338         zmin=1e33
     339         zmax=-1e33
     340         do k=1,klev
     341            do i=1,klon
     342                  zmax=max(zmax,frac_nucl(i,k))
     343                  zmin=min(zmin,frac_nucl(i,k))
     344            enddo
     345         enddo
     346         Print*,'------ coefs de lessivage (min et max) --------'
     347         Print*,'facteur de nucleation ',zmin,zmax
     348         zmin=1e33
     349         zmax=-1e33
     350         do k=1,klev
     351            do i=1,klon
     352                  zmax=max(zmax,frac_impa(i,k))
     353                  zmin=min(zmin,frac_impa(i,k))
     354            enddo
     355         enddo
     356         Print*,'facteur d impaction ',zmin,zmax
     357
     358      ENDIF
     359
     360c   reinitialisation des champs cumules
     361        go to 768
     362      if (mod(iadvtr,istphy).eq.1) then
     363         do k=1,klev
     364            do i=1,klon
     365               mfu(i,k)=0.
     366               mfd(i,k)=0.
     367               en_u(i,k)=0.
     368               de_u(i,k)=0.
     369               en_d(i,k)=0.
     370               de_d(i,k)=0.
     371               coefh(i,k)=0.
     372               t(i,k)=0.
     373               fm_therm(i,k)=0.
     374               entr_therm(i,k)=0.
     375            enddo
     376         enddo
     377         do i=1,klon
     378            pyv1(i)=0.
     379            pyu1(i)=0.
     380         end do
     381         do k=1,nbsrf
     382             do i=1,klon
     383               pftsol(i,k)=0.
     384               ppsrf(i,k)=0.
     385            enddo
     386         enddo
     387
     388         dtcum=0.
     389      endif
     390
     391      do k=1,klev
     392         do i=1,klon
    173393            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
    174394            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
    … …  
    179399            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
    180400                t(i,k)=t(i,k)+pt(i,k)*pdtphys
     401       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
     402       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
    181403         enddo
    182404      enddo
    … …  
    193415
    194416      dtcum=dtcum+pdtphys
    195 c
    196       IF(mod(iadvtr,istphy).eq.0) THEN
    197 c
    198 c   normalisation par le temps cumule
    199          do k=1,klev
    200             do i=1,klon
    201 c              frac_impa=frac_impa : c'est la fraction cumulee qu'on stoke
    202 c              frac_nucl=frac_nucl : c'est la fraction cumulee qu'on stoke
    203                mfu(i,k)=mfu(i,k)/dtcum
    204                mfd(i,k)=mfd(i,k)/dtcum
    205                en_u(i,k)=en_u(i,k)/dtcum
    206                de_u(i,k)=de_u(i,k)/dtcum
    207                en_d(i,k)=en_d(i,k)/dtcum
    208                de_d(i,k)=de_d(i,k)/dtcum
    209                coefh(i,k)=coefh(i,k)/dtcum
    210                 t(i,k)=t(i,k)/dtcum
    211             enddo
    212          enddo
    213          do i=1,klon
    214             rain(i)=rain(i)/dtcum
    215             pyv1(i)=pyv1(i)/dtcum
    216             pyu1(i)=pyu1(i)/dtcum
    217          end do
    218 c modif abderr 23 11 00         do k=1,nbsrf
    219              do i=1,klon
    220               do k=1,nbsrf
    221                pftsol(i,k)=pftsol(i,k)/dtcum
    222                ppsrf(i,k)=ppsrf(i,k)/dtcum
    223               enddo
    224                pftsol1(i) = pftsol(i,1)
    225                pftsol2(i) = pftsol(i,2)
    226                pftsol3(i) = pftsol(i,3)
    227                pftsol4(i) = pftsol(i,4)
    228 
    229 c               ppsrf(i,k)=ppsrf(i,k)/dtcum
    230                ppsrf1(i) = ppsrf(i,1)
    231                ppsrf2(i) = ppsrf(i,2)
    232                ppsrf3(i) = ppsrf(i,3)
    233                ppsrf4(i) = ppsrf(i,4)
    234 
    235             enddo
    236 c         enddo
    237 c
    238 c   ecriture des champs
    239 c
    240          irec=irec+1
    241 
    242 ccccc
    243       print*,'AVANT ECRITURE'
    244          CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
    245          CALL histwrite(physid,"t",itap,zx_tmp_3d,
    246      .                                   iim*(jjm+1)*klev,ndex)
    247       print*,'APRES ECRITURE'
    248 
    249          CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
    250       CALL histwrite(physid,"mfu",itap,zx_tmp_3d,
    251      .                                   iim*(jjm+1)*klev,ndex)
    252         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
    253       CALL histwrite(physid,"mfd",itap,zx_tmp_3d,
    254      .                                   iim*(jjm+1)*klev,ndex)
    255         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
    256       CALL histwrite(physid,"en_u",itap,zx_tmp_3d,
    257      .                                   iim*(jjm+1)*klev,ndex)
    258         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
    259       CALL histwrite(physid,"de_u",itap,zx_tmp_3d,
    260      .                                   iim*(jjm+1)*klev,ndex)
    261         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
    262       CALL histwrite(physid,"en_d",itap,zx_tmp_3d,
    263      .                                   iim*(jjm+1)*klev,ndex)
    264         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)
    265       CALL histwrite(physid,"de_d",itap,zx_tmp_3d,
    266      .                                   iim*(jjm+1)*klev,ndex)
    267         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)
    268       CALL histwrite(physid,"coefh",itap,zx_tmp_3d,
    269      .                                   iim*(jjm+1)*klev,ndex)
    270 cccc
    271        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
    272         CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d,
    273      .  iim*(jjm+1)*klev,ndex)
    274 
    275         CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
    276         CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d,
    277      .  iim*(jjm+1)*klev,ndex)
    278 
    279         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
    280       CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
    281 
    282         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
    283       CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
    284 
    285         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
    286       CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,
    287      .                                   iim*(jjm+1),ndex)
    288          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
    289       CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,
    290      .                                   iim*(jjm+1),ndex)
    291           CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
    292       CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,
    293      .                                   iim*(jjm+1),ndex)
    294 
    295 c
    296          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
    297       CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,
    298      .                                   iim*(jjm+1),ndex)
    299 
    300         CALL gr_fi_ecrit(1,klon,iim,jjm+1, rain, zx_tmp_2d)
    301       CALL histwrite(physid,"rain",itap,zx_tmp_2d,
    302      .                                   iim*(jjm+1),ndex)
    303 
    304         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
    305       CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,
    306      .                                   iim*(jjm+1),ndex)
    307         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
    308       CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,
    309      .                                   iim*(jjm+1),ndex)
    310         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
    311       CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,
    312      .                                   iim*(jjm+1),ndex)
    313         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
    314       CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,
    315      .                                   iim*(jjm+1),ndex)
    316 
    317 c
    318 cAA Test sur la valeur des coefficients de lessivage
    319 c
    320          zmin=1e33
    321          zmax=-1e33
    322          do k=1,klev
    323             do i=1,klon
    324                   zmax=max(zmax,frac_nucl(i,k))
    325                   zmin=min(zmin,frac_nucl(i,k))
    326             enddo
    327          enddo
    328          Print*,'------ coefs de lessivage (min et max) --------'
    329          Print*,'facteur de nucleation ',zmin,zmax
    330          zmin=1e33
    331          zmax=-1e33
    332          do k=1,klev
    333             do i=1,klon
    334                   zmax=max(zmax,frac_impa(i,k))
    335                   zmin=min(zmin,frac_impa(i,k))
    336             enddo
    337          enddo
    338          Print*,'facteur d impaction ',zmin,zmax
    339 
    340       ENDIF
    341 
     417768   continue
    342418
    343419      RETURN

  • LMDZ4/trunk/libf/phylmd/phytrac.F

    r524 r541  
    2323     I                    pde_d,
    2424     I                    coefh,
     25     I                    fm_therm,entr_therm,
    2526     I                    yu1,
    2627     I                    yv1,
    … …  
    130131      logical debutphy       ! le flag de l'initialisation de la physique
    131132      logical lafin          ! le flag de la fin de la physique
    132 
     133c Olivia     
     134      integer isplit,nsplit
    133135      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--lessivage convection
    134136      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--lessivage large-scale
    … …  
    146148      REAL pmfd(nlon,nlev)  ! flux de masse dans le panache descendant
    147149      REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant
     150
     151c
     152c   thermiques:
     153c   -----------
     154c
     155      real fm_therm(klon,klev+1),entr_therm(klon,klev)
     156        real fm_therm1(klon,klev)
     157c
    148158      REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant
    149159      REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant
    … …  
    265275      REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs
    266276      REAL d_tr_cl(klon,klev) ! tendance de traceurs  couche limite
    267       REAL d_tr_cv(klon,klev) ! tendance de traceurs  convection
     277      REAL d_tr_cli(klon,klev,nbtr) ! tendance de traceurs  CL pour chq traceur
     278      REAL d_tr_cv(klon,klev) ! tendance de traceurs  convection
     279      REAL d_tr_cvi(klon,klev,nbtr) ! tendance de traceurs  conv pour chq traceur
     280      REAL d_tr_th(klon,klev,nbtr) ! la tendance des thermiques
    268281      REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance
    269282c                                   ! radioactive du rn - > pb
    … …  
    280293      REAL flestottr(klon,klev,nbtr) ! flux de lessivage
    281294c                                    ! dans chaque couche
     295      real zmasse(klon,klev)
     296      real ztra_th(klon,klev)
    282297
    283298C
    … …  
    288303c-------------
    289304      logical first,couchelimite,convection,lessivage,sorties,
    290      s        rnpb,inirnpb
    291       save first,couchelimite,convection,lessivage,sorties,
    292      s     inirnpb
    293       data first,couchelimite,convection,lessivage,sorties
    294      s     /.true.,.true.,.false.,.true.,.true./
     305     s        rnpb,inirnpb,thermiques
     306      save first,couchelimite,convection,lessivage,thermiques,
     307     s        sorties,inirnpb
     308c      data first,couchelimite,convection,lessivage,sorties
     309c     s     /.true.,.true.,.false.,.true.,.true./
     310c Olivia
     311       data first,couchelimite,convection,lessivage,
     312     s      thermiques,sorties
     313     s     /.true.,.true.,.true.,.true.,.true.,.true./
     314
    295315
    296316#ifdef INCA
    … …  
    522542      DO i = 1, klon
    523543         tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k)
     544         d_tr_cvi(i,k,it)=d_tr_cv(i,k)
     545c        print*,'en k i d_tr_cv=',k,i,d_tr_cv(i,k)
    524546      ENDDO
    525547      ENDDO
    … …  
    541563c      enddo
    542564
     565
     566c======================================================================
     567c   Calcul de l'effet des thermiques
     568c======================================================================
     569
     570      do k=1,klev
     571         do i=1,klon
     572            zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
     573         enddo
     574      enddo
     575
     576c      print*,'masse dans ph ',zmasse
     577      do it=1,nqmax
     578         do k=1,klev
     579            do i=1,klon
     580               d_tr_th(i,k,it)=0.
     581               tr_seri(i,k,it)=max(tr_seri(i,k,it),0.)
     582               tr_seri(i,k,it)=min(tr_seri(i,k,it),1.e10)
     583            enddo
     584         enddo
     585      enddo
     586
     587      if (thermiques) then
     588        print*,'calcul de leffet des thermiques'
     589        nsplit=10
     590        DO it=1, nqmax
     591c        WRITE(itn,'(i1)') it
     592c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'conv it='//itn)
     593c            print*,'avant dqthermiquesretro'
     594c             call dump2d(iim,jjm-1,tr_seri(2,1,1),'TR_SERI      ')
     595
     596         do isplit=1,nsplit
     597c  Abderr 25 11 02
     598C Thermiques
     599c       print*,'Avant dans phytrac',avant
     600            call dqthermcell(klon,klev,pdtphys/nsplit
     601     .       ,fm_therm,entr_therm,zmasse
     602     .       ,tr_seri(1:klon,1:klev,it),d_tr,ztra_th)
     603
     604            do k=1,klev
     605               do i=1,klon
     606                  d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit
     607                  d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k)
     608                  tr_seri(i,k,it)=max(tr_seri(i,k,it)+d_tr(i,k),0.)
     609               enddo
     610            enddo
     611          enddo ! nsplit
     612          print*,'apres thermiques'
     613c             call dump2d(iim,jjm-1,d_tr_th(1,1,1),'d_tr_th      ')
     614c            do k=1,klev
     615c       print*,'d_tr_th(',k,')=',tr_seri(280,k,1)
     616c          enddo
     617
     618c        WRITE(itn,'(i1)') it
     619c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'therm it='//itn)
     620       ENDDO ! it
     621       endif ! Thermiques
     622c       print*,'ATTENTION: sdans thermniques'
     623     
    543624c======================================================================
    544625c   Calcul de l'effet de la couche limite
    … …  
    576657            DO i = 1, klon
    577658              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k)
     659              d_tr_cli(i,k,it)=d_tr_cl(i,k)
    578660            ENDDO
    579661          ENDDO
    … …  
    608690               DO i = 1, klon
    609691                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k)
     692                  d_tr_cli(i,k,it)=d_tr_cl(i,k)
    610693               ENDDO
    611694            ENDDO

  • LMDZ4/trunk/libf/phylmd/read_pstoke.F

    r524 r541  
    77     .   zrec,zklono,zklevo,airefi,phisfi,
    88     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
     9     .   fm_therm,en_therm,
    910     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
     11
     12C******************************************************************************
     13C  Frederic HOURDIN, Abderrahmane IDELKADI
     14C Lecture des parametres physique stockes online necessaires pour
     15C recalculer offline le transport de traceurs sur une grille 2x plus fine que
     16C celle online
     17C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
     18C******************************************************************************
    1019
    1120
    … …  
    2635#include "dimphy.h"
    2736       
    28           integer*4 klono,klevo,imo,jmo
     37          integer klono,klevo,imo,jmo
    2938          parameter (imo=iim/2,jmo=(jjm+1)/2)
    3039          parameter(klono=(jmo-1)*imo+2,klevo=llm)
    31           REAL*4 phisfi(klono)
    32           REAL*4 phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
    33 
    34           REAL*4 mfu(klono,klevo), mfd(klono,klevo)
    35           REAL*4 en_u(klono,klevo), de_u(klono,klevo)
    36           REAL*4 en_d(klono,klevo), de_d(klono,klevo)
    37           REAL*4 coefh(klono,klevo)
    38 
    39           REAL*4 mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
    40           REAL*4 en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
    41           REAL*4 en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
    42           REAL*4 coefh2(imo,jmo+1,klevo)
    43 
    44           REAL*4 pl(klevo)
     40          REAL phisfi(klono)
     41          REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
     42
     43          REAL mfu(klono,klevo), mfd(klono,klevo)
     44          REAL en_u(klono,klevo), de_u(klono,klevo)
     45          REAL en_d(klono,klevo), de_d(klono,klevo)
     46          REAL coefh(klono,klevo)
     47           REAL fm_therm(klono,klevo),en_therm(klono,klevo)
     48
     49          REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
     50          REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
     51          REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
     52          REAL coefh2(imo,jmo+1,klevo)
     53           REAL fm_therm2(imo,jmo+1,klevo)
     54           REAL en_therm2(imo,jmo+1,klevo)
     55
     56          REAL pl(klevo)
    4557          integer irec
    46           integer*4 xid,yid,zid,tid
     58          integer xid,yid,zid,tid
    4759          real zrec,zklono,zklevo,zim,zjm
    48           integer*4 ncrec,ncklono,ncklevo,ncim,ncjm
    49 
    50           real*4 airefi(klono)
    51           character namedim
     60          integer ncrec,ncklono,ncklevo,ncim,ncjm
     61
     62          real airefi(klono)
     63          character*20 namedim
    5264
    5365c  !! attention !!
    … …  
    5668         
    5769         
    58           REAL*4 frac_impa(klono,klevo), frac_nucl(klono,klevo)
    59           REAL*4 frac_impa2(imo,jmo+1,klevo),
     70          REAL frac_impa(klono,klevo), frac_nucl(klono,klevo)
     71          REAL frac_impa2(imo,jmo+1,klevo),
    6072     .     frac_nucl2(imo,jmo+1,klevo)
    61           REAL*4 pyu1(klono), pyv1(klono)
    62           REAL*4 pyu12(imo,jmo+1), pyv12(imo,jmo+1)
    63           REAL*4 ftsol(klono,nbsrf)
    64           REAL*4 psrf(klono,nbsrf)
    65           REAL*4 ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
    66           REAL*4 psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
    67           REAL*4 ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
     73          REAL pyu1(klono), pyv1(klono)
     74          REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1)
     75          REAL ftsol(klono,nbsrf)
     76          REAL psrf(klono,nbsrf)
     77          REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
     78          REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
     79          REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
    6880     .     ftsol32(imo,jmo+1),
    6981     .     ftsol42(imo,jmo+1)
    70           REAL*4 psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
     82          REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
    7183     .     psrf42(imo,jmo+1)
    72                 REAL*4 t(klono,klevo)
    73                 REAL*4 t2(imo,jmo+1)   
     84                REAL t(klono,klevo)
     85                REAL t2(imo,jmo+1,klevo)       
    7486          integer ncidp
    7587          save ncidp
    … …  
    7789          integer varidmfu, varidmfd, varidps, varidenu, variddeu       
    7890          integer varidend,varidded,varidch,varidfi,varidfn
     91           integer varidfmth,varidenth
    7992          integer varidyu1,varidyv1,varidpl,varidai,varididvt
    8093          integer varidfts1,varidfts2,varidfts3,varidfts4
    … …  
    8295          save varidmfu, varidmfd, varidps, varidenu, variddeu
    8396          save varidend,varidded,varidch,varidfi,varidfn
     97           save varidfmth,varidenth
    8498          save varidyu1,varidyv1,varidpl,varidai,varididvt
    8599          save varidfts1,varidfts2,varidfts3,varidfts4
    … …  
    113127            print*,'ncidp,varidai',ncidp,varidai
    114128
     129c A FAIRE: Es-il necessaire de stocke t?
    115130                varidt=NCVID(ncidp,'t',rcode)
    116131                print*,'ncidp,varidt',ncidp,varidt
     132
    117133            varidmfu=NCVID(ncidp,'mfu',rcode)
    118134            print*,'ncidp,varidmfu',ncidp,varidmfu
    … …  
    136152            print*,'ncidp,varidch',ncidp,varidch
    137153       
     154c abder (pour thermiques)
     155             varidfmth=NCVID(ncidp,'fm_th',rcode)
     156             print*,'ncidp,varidfmth',ncidp,varidfmth
     157
     158             varidenth=NCVID(ncidp,'en_th',rcode)
     159             print*,'ncidp,varidenth',ncidp,varidenth
     160
    138161            varidfi=NCVID(ncidp,'frac_impa',rcode)
    139162            print*,'ncidp,varidfi',ncidp,varidfi
    … …  
    200223
    201224c niveaux de pression
    202 
    203             status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
     225#ifdef NC_DOUBLE
     226      status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl)
     227#else
     228      status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
     229#endif
    204230
    205231c lecture de aire et phis
    … …  
    216242
    217243c phis
     244#ifdef NC_DOUBLE
     245      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
     246#else
    218247      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
    219 c      print*,'WARNING!!! Correction bidon pour palier a un '
    220 c      print*,'probleme dans la creation des fichiers nc'
    221 c      call correctbid(iim,jjp1*1,phisfi2)
    222 c      call dump2d(iip1-1,jjp1,phisfi2,'PHISNC')
     248#endif
    223249      call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi)
    224250
    225251c aire
     252#ifdef NC_DOUBLE
     253      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
     254#else
    226255      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
    227 c      call correctbid(iim,jjp1*1,airefi2)
    228 c       call dump2d(iip1-1,jjp1,airefi2,'AIRENC')
     256#endif
    229257       call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi)
    230258      else
    … …  
    249277      count(4)=1
    250278
     279
     280C *** Lessivage******************************************************
    251281c frac_impa
    252 
     282#ifdef NC_DOUBLE
     283      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
     284#else
    253285      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
    254 c      print*,'WARNING!!! Correction bidon pour palier a un '
    255 c      print*,'probleme dans la creation des fichiers nc'
    256 c      call correctbid(iim,jjp1*klevo,frac_impa2)
    257 c      call dump2d(iip1-1,jjp1,frac_impa2,'FINC COUCHE 1')
     286#endif
    258287      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa)
    259288
    260289c frac_nucl
    261 
     290#ifdef NC_DOUBLE
     291      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
     292#else
    262293      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
    263 c      print*,'WARNING!!! Correction bidon pour palier a un '
    264 c      print*,'probleme dans la creation des fichiers nc'
    265 c      call correctbid(iim,jjp1*klevo,frac_nucl2)
    266 c      call dump2d(iip1-1,jjp1,frac_nucl2,'FINC COUCHE 1')
     294#endif
    267295      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl)
    268296
     297C*** Temperature ******************************************************
    269298c abder t
     299#ifdef NC_DOUBLE
     300      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
     301#else
    270302      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
     303#endif
    271304      call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t)
    272305
     306C*** Flux pour le calcul de la convection TIEDTK ***********************
    273307c mfu
     308#ifdef NC_DOUBLE
     309      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
     310#else
    274311      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
    275 c      print*,'WARNING!!! Correction bidon pour palier a un '
    276 c      print*,'probleme dans la creation des fichiers nc'
    277 c      call correctbid(iim,jjp1*klevo,mfu2)
    278 c      call dump2d(iip1-1,jjp1,mfu2,'MFUNC COUCHE 1')
     312#endif
    279313      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu)
    280314
    281315c mfd
     316#ifdef NC_DOUBLE
     317      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
     318#else
    282319      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
    283 c      print*,'WARNING!!! Correction bidon pour palier a un '
    284 c      print*,'probleme dans la creation des fichiers nc'
    285 c      call correctbid(iim,jjp1*klevo,mfd2)
    286 c      call dump2d(iip1-1,jjp1,mfd2,'MFDNC COUCHE 1')
     320#endif
    287321      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd)
    288322
    289323c en_u
     324#ifdef NC_DOUBLE
     325      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
     326#else
    290327      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
    291 c      print*,'WARNING!!! Correction bidon pour palier a un '
    292 c      print*,'probleme dans la creation des fichiers nc'
    293 c      call correctbid(iim,jjp1*klevo,en_u2)
    294 c      call dump2d(iip1-1,jjp1,en_u2,'ENUNC COUCHE 1')
     328#endif
    295329      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u)
    296330
    297331c de_u
     332#ifdef NC_DOUBLE
     333      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
     334#else
    298335      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
    299 c      print*,'WARNING!!! Correction bidon pour palier a un '
    300 c      print*,'probleme dans la creation des fichiers nc'
    301 c      call correctbid(iim,jjp1*klevo,de_u2)
    302 c      call dump2d(iip1-1,jjp1,de_u2,'DEUNC COUCHE 1')
     336#endif
    303337      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u)
    304338
    305339c en_d
     340#ifdef NC_DOUBLE
     341      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
     342#else
    306343      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
    307 c      print*,'WARNING!!! Correction bidon pour palier a un '
    308 c      print*,'probleme dans la creation des fichiers nc'
    309 c      call correctbid(iim,jjp1*klevo,en_d2)
    310 c      call dump2d(iip1-1,jjp1,en_d2,'ENDNC COUCHE 1')
     344#endif
    311345      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d)
    312346
    313347c de_d
     348#ifdef NC_DOUBLE
     349      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
     350#else
    314351      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
    315 c      print*,'WARNING!!! Correction bidon pour palier a un '
    316 c      print*,'probleme dans la creation des fichiers nc'
    317 c      call correctbid(iim,jjp1*klevo,de_d2)
    318 c      call dump2d(iip1-1,jjp1,de_d2,'DEDNC COUCHE 1')
     352#endif
    319353      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d)
    320354
     355C **** Coeffecient du mellange turbulent**********************************
    321356c coefh
     357#ifdef NC_DOUBLE
     358      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
     359#else
    322360      status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
    323 c      print*,'WARNING!!! Correction bidon pour palier a un '
    324 c      print*,'probleme dans la creation des fichiers nc'
    325 c      call correctbid(iim,jjp1*klevo,coefh2)
    326 c      call dump2d(iip1-1,jjp1,coefh2,'CHNC COUCHE 1')
     361#endif
    327362       call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh)
    328363
     364C*** Flux ascendant et entrant pour les Thermiques************************
     365cabder thermiques
     366#ifdef NC_DOUBLE
     367      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2)
     368#else
     369      status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2)
     370#endif
     371      call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm)
     372
     373#ifdef NC_DOUBLE
     374      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2)
     375#else
     376      status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2)
     377#endif
     378      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm)
     379
     380C*** Vitesses aux sol ******************************************************
    329381      start(3)=irec
    330382      start(4)=0
    331383      count(3)=1
    332384      count(4)=0
    333 
    334385c pyu1
     386#ifdef NC_DOUBLE
     387      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
     388#else
    335389      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
    336 c      print*,'WARNING!!! Correction bidon pour palier a un '
    337 c      print*,'probleme dans la creation des fichiers nc'
    338 c      call correctbid(iim,jjp1*1,pyu12)
    339 c      call dump2d(iip1-1,jjp1,pyu12,'PYU1NC')
     390#endif
    340391      call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1)
    341392
    342393c pyv1
     394#ifdef NC_DOUBLE
     395      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
     396#else
    343397      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
    344 c      print*,'WARNING!!! Correction bidon pour palier a un '
    345 c      print*,'probleme dans la creation des fichiers nc'
    346 c      call correctbid(iim,jjp1*1,pyv12)
    347 c      call dump2d(iip1-1,jjp1,pyv12,'PYV1NC')
     398#endif
    348399      call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1)
    349400
     401C*** Temperature au sol ********************************************
    350402c ftsol1
     403#ifdef NC_DOUBLE
     404      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
     405#else
    351406      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
    352 c      print*,'WARNING!!! Correction bidon pour palier a un '
    353 c      print*,'probleme dans la creation des fichiers nc'
    354 c      call correctbid(iim,jjp1*1,ftsol12)
    355 c      call dump2d(iip1-1,jjp1,ftsol12,'FTS1NC')
     407#endif
    356408       call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1)
    357409
    358410c ftsol2
     411#ifdef NC_DOUBLE
     412      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
     413#else
    359414      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
    360 c      print*,'WARNING!!! Correction bidon pour palier a un '
    361 c      print*,'probleme dans la creation des fichiers nc'
    362 c      call correctbid(iim,jjp1*1,ftsol22)
    363 c      call dump2d(iip1-1,jjp1,ftsol22,'FTS2NC')
     415#endif
    364416      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2)
    365417
    366418c ftsol3
     419#ifdef NC_DOUBLE
     420      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
     421#else
    367422      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
    368 c      print*,'WARNING!!! Correction bidon pour palier a un '
    369 c      print*,'probleme dans la creation des fichiers nc'
    370 c      call correctbid(iim,jjp1*1,ftsol32)
    371 c      call dump2d(iip1-1,jjp1,ftsol32,'FTS3NC')
     423#endif
    372424      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3)
    373425
    374426c ftsol4
     427#ifdef NC_DOUBLE
     428      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
     429#else
    375430      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
    376 c      print*,'WARNING!!! Correction bidon pour palier a un '
    377 c      print*,'probleme dans la creation des fichiers nc'
    378 c      call correctbid(iim,jjp1*1,ftsol42)
    379 c      call dump2d(iip1-1,jjp1,ftsol42,'FTS4NC')
     431#endif
    380432      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4)
    381433
     434C*** Nature du sol **************************************************
    382435c psrf1
     436#ifdef NC_DOUBLE
     437      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
     438#else
    383439      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
    384 c      print*,'WARNING!!! Correction bidon pour palier a un '
    385 c      print*,'probleme dans la creation des fichiers nc'
    386 c      call correctbid(iim,jjp1*1,psrf12)
    387 c      call dump2d(iip1-1,jjp1,psrf12,'PSRF1NC')
     440#endif
    388441      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1)
    389442
    390443c psrf2
     444#ifdef NC_DOUBLE
     445      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
     446#else
    391447      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
    392 c      print*,'WARNING!!! Correction bidon pour palier a un '
    393 c      print*,'probleme dans la creation des fichiers nc'
    394 c      call correctbid(iim,jjp1*1,psrf22)
    395 c      call dump2d(iip1-1,jjp1,psrf22,'PSRF2NC')
     448#endif
    396449      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2)
    397450
    398451c psrf3
     452#ifdef NC_DOUBLE
     453      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
     454#else
    399455      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
    400 c      print*,'WARNING!!! Correction bidon pour palier a un '
    401 c      print*,'probleme dans la creation des fichiers nc'
    402 c      call correctbid(iim,jjp1*1,psrf32)
    403 c      call dump2d(iip1-1,jjp1,psrf32,'PSRF3NC')
     456#endif
    404457      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3)
    405458
    406459c psrf4
     460#ifdef NC_DOUBLE
     461      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
     462#else
    407463      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
    408 c      print*,'WARNING!!! Correction bidon pour palier a un '
    409 c      print*,'probleme dans la creation des fichiers nc'
    410 c      call correctbid(iim,jjp1*1,psrf42)
    411 c      call dump2d(iip1-1,jjp1,psrf42,'PSRF4NC')
     464#endif
    412465      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4)
    413466       

  • LMDZ4/trunk/libf/phylmd/read_pstoke0.F

    r524 r541  
    77     .   zrec,zkon,zkev,airefi,phisfi,
    88     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
     9     .   fm_therm,en_therm,
    910     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
     11
     12C******************************************************************************
     13C  Frederic HOURDIN, Abderrahmane IDELKADI
     14C Lecture des parametres physique stockes online necessaires pour
     15C recalculer offline le transport des traceurs sur la meme grille que online
     16C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
     17C******************************************************************************
    1018
    1119
    … …  
    2634#include "dimphy.h"
    2735         
    28           integer*4 kon,kev,zkon,zkev
     36          integer kon,kev,zkon,zkev
    2937          parameter(kon=iim*(jjm-1)+2,kev=llm)
    30           REAL*4 phisfi(kon)
    31           REAL*4 phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
    32 
    33           REAL*4 mfu(kon,kev), mfd(kon,kev)
    34           REAL*4 en_u(kon,kev), de_u(kon,kev)
    35           REAL*4 en_d(kon,kev), de_d(kon,kev)
    36           REAL*4 coefh(kon,kev)
    37                 REAL*4 t(kon,kev)
    38 
    39           REAL*4 mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
    40           REAL*4 en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
    41           REAL*4 en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
    42           REAL*4 coefh2(iim,jjm+1,kev)
    43                 REAL*4 t2(iim,jjm+1,kev)
    44 
    45           REAL*4 pl(kev)
     38          REAL phisfi(kon)
     39          REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
     40
     41          REAL mfu(kon,kev), mfd(kon,kev)
     42          REAL en_u(kon,kev), de_u(kon,kev)
     43          REAL en_d(kon,kev), de_d(kon,kev)
     44          REAL coefh(kon,kev)
     45
     46c abd 25 11 02
     47c Thermiques
     48         REAL fm_therm(kon,kev),en_therm(kon,kev)
     49                REAL t(kon,kev)
     50
     51          REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
     52          REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
     53          REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
     54          REAL coefh2(iim,jjm+1,kev)
     55                REAL t2(iim,jjm+1,kev)
     56c Thermiques
     57         REAL fm_therm2(iim,jjm+1,kev)
     58         REAL en_therm2(iim,jjm+1,kev)       
     59
     60          REAL pl(kev)
    4661          integer irec
    47           integer*4 xid,yid,zid,tid
    48           integer*4 zrec,zim,zjm
    49           integer*4 ncrec,nckon,nckev,ncim,ncjm
    50 
    51           real*4 airefi(kon)
    52           character namedim
     62          integer xid,yid,zid,tid
     63          integer zrec,zim,zjm
     64          integer ncrec,nckon,nckev,ncim,ncjm
     65
     66          real airefi(kon)
     67          character*20 namedim
    5368
    5469c  !! attention !!
    … …  
    5671c dim de phis??
    5772
    58           REAL*4 frac_impa(kon,kev), frac_nucl(kon,kev)
    59           REAL*4 frac_impa2(iim,jjm+1,kev),
     73          REAL frac_impa(kon,kev), frac_nucl(kon,kev)
     74          REAL frac_impa2(iim,jjm+1,kev),
    6075     .     frac_nucl2(iim,jjm+1,kev)
    61           REAL*4 pyu1(kon), pyv1(kon)
    62           REAL*4 pyu12(iim,jjm+1), pyv12(iim,jjm+1)
    63           REAL*4 ftsol(kon,nbsrf)
    64           REAL*4 psrf(kon,nbsrf)
    65           REAL*4 ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
    66           REAL*4 psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
    67           REAL*4 ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
     76          REAL pyu1(kon), pyv1(kon)
     77          REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
     78          REAL ftsol(kon,nbsrf)
     79          REAL psrf(kon,nbsrf)
     80          REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
     81          REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
     82          REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
    6883     .     ftsol32(iim,jjm+1),
    6984     .     ftsol42(iim,jjm+1)
    70           REAL*4 psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
     85          REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
    7186     .     psrf42(iim,jjm+1)
    7287       
    … …  
    7691                integer varidt
    7792          integer varidend,varidded,varidch,varidfi,varidfn
     93c therm
     94          integer varidfmth,varidenth
    7895          integer varidyu1,varidyv1,varidpl,varidai,varididvt
    7996          integer varidfts1,varidfts2,varidfts3,varidfts4
    … …  
    8299                save varidt
    83100          save varidend,varidded,varidch,varidfi,varidfn
     101c therm
     102           save varidfmth,varidenth
    84103          save varidyu1,varidyv1,varidpl,varidai,varididvt
    85104          save varidfts1,varidfts2,varidfts3,varidfts4
    … …  
    112131            print*,'ncidp,varidai',ncidp,varidai
    113132
     133                varidt=NCVID(ncidp,'t',rcode)
     134                print*,'ncidp,varidt',ncidp,varidt
     135
    114136            varidmfu=NCVID(ncidp,'mfu',rcode)
    115137            print*,'ncidp,varidmfu',ncidp,varidmfu
    116138
    117                 varidt=NCVID(ncidp,'t',rcode)
    118                 print*,'ncidp,varidt',ncidp,varidt
    119 
    120139            varidmfd=NCVID(ncidp,'mfd',rcode)
    121140            print*,'ncidp,varidmfd',ncidp,varidmfd
    … …  
    135154            varidch=NCVID(ncidp,'coefh',rcode)
    136155            print*,'ncidp,varidch',ncidp,varidch
     156
     157c Thermiques
     158            varidfmth=NCVID(ncidp,'fm_th',rcode)
     159            print*,'ncidp,varidfmth',ncidp,varidfmth
     160
     161            varidenth=NCVID(ncidp,'en_th',rcode)
     162            print*,'ncidp,varidenth',ncidp,varidenth
    137163       
    138164            varidfi=NCVID(ncidp,'frac_impa',rcode)
    … …  
    216242
    217243c
     244C**** Geopotentiel au sol ***************************************
    218245c phis
    219       status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
     246#ifdef NC_DOUBLE
     247      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
     248#else
     249        status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
     250#endif
    220251      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
    221252
     253C**** Aires des mails aux sol ************************************
    222254c aire
    223       status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
     255#ifdef NC_DOUBLE
     256      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
     257#else
     258        status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
     259#endif
    224260      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
    225261      else
    … …  
    244280      count(4)=1
    245281
    246 c frac_impa
    247 
    248       status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
    249       call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
    250 
    251 c frac_nucl
    252 
    253       status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
    254       call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
     282C**** Temperature ********************************************
     283cA FAIRE : Es-ce necessaire ?
    255284
    256285c abder t
    257       status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
     286#ifdef NC_DOUBLE
     287      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
     288#else
     289        status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
     290#endif
    258291      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
    259292
     293C**** Flux pour la convection (Tiedtk) ********************************************
    260294c mfu
    261       status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
     295#ifdef NC_DOUBLE
     296      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
     297#else
     298        status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
     299#endif
    262300      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
    263301
    264302c mfd
    265       status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
     303#ifdef NC_DOUBLE
     304      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
     305#else
     306        status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
     307#endif
    266308      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
    267309
    268310c en_u
    269       status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
     311#ifdef NC_DOUBLE
     312      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
     313#else
     314        status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
     315#endif
    270316      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
    271317
    272318c de_u
    273       status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
     319#ifdef NC_DOUBLE
     320      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
     321#else
     322        status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
     323#endif
    274324      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
    275325
    276326c en_d
    277       status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
     327#ifdef NC_DOUBLE
     328      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
     329#else
     330        status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
     331#endif
    278332      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
    279333
    280334c de_d
    281       status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
     335#ifdef NC_DOUBLE
     336      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
     337#else
     338        status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
     339#endif
    282340      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
    283341
     342C**** Coefficient de mellange turbulent *******************************************
    284343c coefh
    285344        print*,'LECTURE de coefh a irec =',irec
    286        status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
     345#ifdef NC_DOUBLE
     346      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
     347#else
     348        status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
     349#endif
    287350       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
     351c      call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
     352c      call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
     353
     354C**** Flux ascendants et entrant dans le thermique **********************************
     355cThermiques
     356       print*,'LECTURE de fm_therm a irec =',irec
     357#ifdef NC_DOUBLE
     358      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
     359     .                         count,fm_therm2)
     360#else
     361       status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
     362     .                         count,fm_therm2)
     363#endif
     364       call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
     365       print*,'LECTURE de en_therm a irec =',irec
     366#ifdef NC_DOUBLE
     367      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
     368     .                          count,en_therm2)
     369#else
     370       status=NF_GET_VARA_REAL(ncidp,varidenth,start,
     371     .                          count,en_therm2)
     372#endif
     373       call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
     374
     375C**** Coefficients de lessivage *******************************************
     376c frac_impa
     377#ifdef NC_DOUBLE
     378      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
     379#else
     380        status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
     381#endif
     382      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
     383
     384c frac_nucl
     385
     386#ifdef NC_DOUBLE
     387      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
     388#else
     389        status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
     390#endif
     391      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
     392
     393C**** Vents aux sol ********************************************
    288394
    289395      start(3)=irec
    … …  
    294400c pyu1
    295401        print*,'LECTURE de yu1 a irec =',irec
    296       status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
     402#ifdef NC_DOUBLE
     403      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
     404#else
     405        status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
     406#endif
    297407      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
    298408
    299409c pyv1
    300410        print*,'LECTURE de yv1 a irec =',irec
    301       status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
     411#ifdef NC_DOUBLE
     412      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
     413#else
     414        status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
     415#endif
    302416      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
    303417
     418C**** Temerature au sol ********************************************
    304419c ftsol1
    305420        print*,'LECTURE de ftsol1 a irec =',irec
     421#ifdef NC_DOUBLE
     422      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
     423#else
    306424      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
     425#endif
    307426       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
    308427
    309428c ftsol2
    310429        print*,'LECTURE de ftsol2 a irec =',irec
     430#ifdef NC_DOUBLE
     431      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
     432#else
    311433      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
     434#endif
    312435      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
    313436
    314437c ftsol3
    315438         print*,'LECTURE de ftsol3 a irec =',irec
     439#ifdef NC_DOUBLE
     440      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
     441#else
    316442      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
     443#endif
    317444      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
    318445
    319446c ftsol4
     447#ifdef NC_DOUBLE
     448      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
     449#else
    320450      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
     451#endif
    321452      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
    322453
     454C**** Nature sol ********************************************
    323455c psrf1
     456#ifdef NC_DOUBLE
     457      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
     458#else
    324459      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
     460#endif
    325461c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
    326462      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
    327463
    328464c psrf2
     465#ifdef NC_DOUBLE
     466      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
     467#else
    329468      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
     469#endif
    330470c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
    331471      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
    332472
    333473c psrf3
     474#ifdef NC_DOUBLE
     475      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
     476#else
    334477      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
     478#endif
    335479      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
    336480
    337481c psrf4
     482#ifdef NC_DOUBLE
     483      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
     484#else
    338485      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
     486#endif
    339487      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
    340488       
    … …  
    344492        psrf(i,2) = psrf2(i)
    345493        psrf(i,3) = psrf3(i)
     494c test abderr
     495c       print*,'Dans read_pstoke psrf3 =',psrf3(i),i
    346496        psrf(i,4) = psrf4(i)
    347497 

  • LMDZ4/trunk/libf/phylmd/write_histrac.h

    r524 r541  
    234234     .                                   iim*(jjm+1)*klev,ndex3d)
    235235      endif
     236     
     237c----Olivia
     238       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_th(1,1,it),zx_tmp_3d)
     239       CALL histwrite(nid_tra,"d_tr_th_"//tnom(it+2),itau_w,zx_tmp_3d,
     240     .                                   iim*(jjm+1)*klev,ndex3d)
     241       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cvi(1,1,it),zx_tmp_3d)
     242       CALL histwrite(nid_tra,"d_tr_cv_"//tnom(it+2),itau_w,zx_tmp_3d,
     243     .                                   iim*(jjm+1)*klev,ndex3d)
     244       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cli(1,1,it),zx_tmp_3d)
     245       CALL histwrite(nid_tra,"d_tr_cl_"//tnom(it+2),itau_w,zx_tmp_3d,
     246     .                                   iim*(jjm+1)*klev,ndex3d)
     247c---fin Olivia     
     248     
    236249#endif
    237250      ENDDO

  • LMDZ4/trunk/makegcm

    r529 r541  
    779779     else
    780780       set opt_link=" -C hopt -float0 $optdbl -P static -L$MODIPSLDIR $link_veget -lsxioipsl $NCDFLIB "
     781     endif
    781782   endif
    782783   set mod_loc_dir="./"

  • LMDZ4/trunk/physiq.def

    r524 r541  
    8080#cdhmax = 2.0E-3
    8181cdhmax = 0.002
    82 
     82iflag_pbl = 1
     83iflag_thermals = 0
Note: See TracChangeset for help on using the changeset viewer.