Ignore:
Timestamp:
Feb 22, 2021, 5:28:31 PM (3 years ago)
Author:
dcugnet
Message:

Extension of the tracers management.

The tracers files can be:

1) "traceur.def": old format, with:

  • the number of tracers on the first line
  • one line for each tracer: <tracer name> <hadv> <vadv> [<parent name>]

2) "tracer.def": new format with one section each model component.
3) "tracer_<name>.def": new format with a single section.

The formats 2 and 3 reading is driven by the "type_trac" key, which can be a

coma-separated list of components.

  • Format 2: read the sections from the "tracer.def" file.
  • format 3: read one section each "tracer_<section name>.def" file.
  • the first line of a section is "&<section name>
  • the other lines start with a tracer name followed by <key>=<val> pairs.
  • the "default" tracer name is reserved ; the other tracers of the section inherit its <key>=<val>, except for the keys that are redefined locally.

This format helps keeping the tracers files compact, thanks to the "default"
special tracer and the three levels of factorization:

  • on the tracers names: a tracer name can be a coma-separated list of tracers => all the tracers of the list have the same <key>=<val> properties
  • on the parents names: the value of the "parent" property can be a coma-separated list of tracers => only possible for geographic tagging tracers
  • on the phases: the property "phases" is [g](l][s] (gas/liquid/solid)

Read information is stored in the vector "tracers(:)", of derived type "tra".

"isotopes_params.def" is a similar file, with one section each isotopes family.
It contains a database of isotopes properties ; if there are second generation
tracers (isotopes), the corresponding sections are read.

Read information is stored in the vector "isotopes(:)", of derived type "iso".

The "getKey" function helps to get the values of the parameters stored in
"tracers" or "isotopes".

Location:
LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem
Files:
13 edited
2 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/advtrac_loc.F

    r2622 r3852  
    2424      USE Vampir
    2525      USE times
    26       USE infotrac, ONLY: nqtot, iadv, ok_iso_verif
     26      USE infotrac, ONLY: nqtot, tracers
    2727      USE control_mod, ONLY: iapp_tracvl, day_step, planet_type
    2828      USE advtrac_mod, ONLY: finmasse
    … …  
    6060      INTEGER ij,l,iq,iiq
    6161      REAL zdpmin, zdpmax
     62      INTEGER, POINTER :: iadv(:)
    6263c----------------------------------------------------------
    6364c     Rajouts pour PPM
    … …  
    7778      type(Request),SAVE :: testRequest
    7879!$OMP THREADPRIVATE(testRequest)
     80
     81      iadv => tracers(:)%iadv
    7982
    8083c  test sur l''eventuelle creation de valeurs negatives de la masse
    … …  
    157160
    158161          !write(*,*) 'advtrac 162: apres appel vlspltgen_loc'
    159       if (ok_iso_verif) then
    160            call check_isotopes(q,ijb_u,ije_u,'advtrac 162')
    161       endif !if (ok_iso_verif) then
     162
     163      call check_isotopes(q,ijb_u,ije_u,'advtrac 162')
    162164
    163165#ifdef DEBUG_IO     

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/check_isotopes_loc.F90

    r3850 r3852  
    1         subroutine check_isotopes(q,ijb,ije,err_msg)
    2         USE infotrac
    3         USE parallel_lmdz
    4         implicit none
     1SUBROUTINE check_isotopes(q, ijb, ije, err_msg)
     2  USE strings_mod, ONLY: strIdx, msg
     3  USE infotrac,    ONLY: isotope, isoSelect, iH2O, isoCheck, isoName, nqtot, niso, nitr, nzon, npha, iTraPha, iZonIso, tnat
     4  USE parallel_lmdz
     5  IMPLICIT NONE
     6#include "dimensions.h"
     7  REAL,             INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot)
     8  INTEGER,          INTENT(IN)    :: ijb, ije    !--- Can be local and different from ijb_u,ije_u, for example in qminimum
     9  CHARACTER(LEN=*), INTENT(IN)    :: err_msg     !--- Error message to display
     10  CHARACTER(LEN=256) :: msg1, modname
     11  INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau
     12  INTEGER, ALLOCATABLE :: ix(:)
     13  REAL    :: xtractot, xiiso, deltaD, q1, q2
     14  REAL, PARAMETER :: borne     = 1e19,  &
     15                     errmax    = 1e-8,  &        !--- Max. absolute error
     16                     errmaxrel = 1e-8,  &        !--- Max. relative error
     17                     qmin      = 1e-11, &
     18                     deltaDmax = 200.0, &
     19                     deltaDmin =-999.9, &
     20                     ridicule  = 1e-12
     21  INTEGER, SAVE :: ixH2O, ixHDO, ixO18
     22!OMP THREADPRIVATE(ixH2O, ixHDO, ixO18)
     23  LOGICAL, SAVE :: first=.TRUE.
     24!OMP THREADPRIVATE(first)
    525
    6 #include "dimensions.h"
     26  modname = 'check_isotopes'
     27  IF(first) THEN
     28    IF(isoSelect('H2O')) RETURN
     29    ixH2O = strIdx(isoName,'H2[16]O')
     30    ixHDO = strIdx(isoName,'H[2]HO')
     31    ixO18 = strIdx(isoName,'H2[18]O')
     32    first = .FALSE.
     33  ELSE
     34    IF(isoSelect(iH2O)) RETURN
     35  END IF
     36  IF(.NOT.isoCheck .OR. niso == 0) RETURN        !--- No need to check or no isotopes => finished
    737
    8         ! inputs
    9         integer ijb,ije ! peut être local et différent de ijb_u,ije_u, ex: dans qminimum
    10         real q(ijb_u:ije_u,llm,nqtot)
    11         character*(*) err_msg ! message d''erreur à afficher
     38  !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
     39  DO ixt = 1, nitr
     40    DO ipha = 1, npha
     41      iq = iTraPha(ixt,ipha)
     42!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     43      DO k = 1, llm
     44        DO i = ijb, ije
     45          IF(ABS(q(i,k,iq))<borne) CYCLE
     46          WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')isoName(ixt),i,k,iq,q(i,k,iq); CALL msg(msg1)
     47          CALL abort_gcm(modname, 'Error in iso_verif_noNaN: '//TRIM(err_msg), 1)
     48          STOP
     49        END DO
     50      END DO
     51!$OMP END DO NOWAIT
     52    END DO
     53  END DO
    1254
    13         ! locals
    14         integer ixt,phase,k,i,iq,iiso,izone,ieau,iqeau
    15         real xtractot,xiiso
    16         real borne
    17         real qmin
    18         real errmax ! erreur maximale en absolu.
    19         real errmaxrel ! erreur maximale en relatif autorisée
    20         real deltaDmax,deltaDmin
    21         real ridicule
    22         parameter (borne=1e19)
    23         parameter (errmax=1e-8)
    24         parameter (errmaxrel=1e-3)
    25         parameter (qmin=1e-11)
    26         parameter (deltaDmax=200.0,deltaDmin=-999.9)
    27         parameter (ridicule=1e-12)
    28         real deltaD
     55  !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
     56  ixt = iH2O
     57  IF(ixt /= 0) THEN
     58    DO ipha = 1, npha
     59      iq = iTraPha(ixt,ipha)
     60!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     61      DO k = 1, llm
     62        DO i = ijb, ije
     63          q1 = q(i,k,ipha); q2 = q(i,k,iq)
     64          IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) < errmaxrel) CYCLE
     65          WRITE(msg1,'("ixt = ",i0)')ixt;                                      CALL msg(msg1)
     66          WRITE(msg1,'("q(",i0,",",i0,",iq=",i0,") = ",ES12.4)')i, k, iq, q2;  CALL msg(msg1)
     67          WRITE(msg1,'("q(",i0,",",i0,",ipha=",i0,") = ",ES12.4)')i,k,ipha,q1; CALL msg(msg1)
     68          CALL abort_gcm(modname, 'Error in iso_verif_egalite: '//TRIM(err_msg), 1)
     69          q(i,k,iq) = q(i,k,ipha)                !--- Bidouille pour convergence
     70        END DO
     71      END DO
     72!$OMP END DO NOWAIT
     73    END DO
     74  END IF
    2975
    30         if (ok_isotopes) then
     76  !--- CHECK DELTA ANOMALIES
     77  ix = [ixHDO, ixO18]
     78  DO iiso = 1, SIZE(ix)
     79    ixt = ix(iiso)
     80    IF(ixt  == 0) CYCLE
     81    DO ipha = 1, npha
     82      iq = iTraPha(ixt,ipha)
     83!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     84      DO k = 1, llm
     85        DO i = ijb, ije
     86          q1 = q(i,k,ipha); q2 = q(i,k,iq)
     87          IF(q2 <= qmin) CYCLE
     88          deltaD = (q2/q1/tnat(ixt)-1)*1000
     89          IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
     90          WRITE(msg1,'("ixt = ",i0)')ixt;                                     CALL msg(msg1)
     91          WRITE(msg1,'("q(",i0,",",i0,",iq=",i0,") = ",ES12.4)')i, k, iq, q2; CALL msg(msg1)
     92          WRITE(msg1,'("q=",ES12.4)')q(i,k,:);                                CALL msg(msg1)
     93          WRITE(msg1,'("deltaD=",ES12.4)')deltaD;                             CALL msg(msg1)
     94          CALL abort_gcm(modname, 'Error in iso_verif_aberrant: '//TRIM(err_msg), 1)
     95        END DO
     96      END DO
     97!$OMP END DO NOWAIT
     98    END DO
     99  END DO
    31100
    32         !write(*,*) 'check_isotopes 31: err_msg=',err_msg
    33         ! verifier que rien n'est NaN
    34         do ixt=1,ntraciso
    35           do phase=1,nqo
    36             iq=iqiso(ixt,phase)
    37 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    38             do k=1,llm
    39               DO i = ijb,ije
    40                 if ((q(i,k,iq).gt.-borne).and.
    41      :            (q(i,k,iq).lt.borne)) then
    42                 else !if ((x(ixt,i,j).gt.-borne).and.
    43                   write(*,*) 'erreur detectee par iso_verif_noNaN:'
    44                   write(*,*) err_msg
    45                   write(*,*) 'q,i,k,iq=',q(i,k,iq),i,k,iq
    46                   write(*,*) 'borne=',borne
    47                   stop
    48                 endif  !if ((x(ixt,i,j).gt.-borne).and.
    49               enddo !DO i = ijb,ije
    50             enddo !do k=1,llm
    51 c$OMP END DO NOWAIT
    52           enddo !do phase=1,nqo
    53         enddo !do ixt=1,ntraciso
     101  !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
     102  IF(nitr == 0) RETURN
     103  IF(ixH2O /= 0 .AND. ixHDO /= 0) THEN
     104    DO izon = 1, nzon
     105      ixt  = iZonIso(izon, ixHDO)
     106      ieau = iZonIso(izon, ixH2O)
     107      DO ipha = 1, npha
     108        iq    = iTraPha(ixt,  ipha)
     109        iqeau = iTraPha(ieau, ipha)
     110!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     111        DO k = 1, llm
     112          DO i = ijb, ije
     113            IF(q(i,k,iq)<=qmin) CYCLE
     114            deltaD = (q(i,k,iq)/q(i,k,iqeau)/tnat(ixHDO)-1)*1000
     115            IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
     116            WRITE(msg1,'("izon, ipha =",2i0)')izon, ipha;                              CALL msg(msg1)
     117            WRITE(msg1,'( "ixt, ieau =",2i0)') ixt, ieau;                              CALL msg(msg1)
     118            WRITE(msg1,'("q(",i0,",",i0,",iq=",i0,") = ",ES12.4)')i, k, iq, q(i,k,iq); CALL msg(msg1)
     119            WRITE(msg1,'("deltaD=",ES12.4)')deltaD;                                    CALL msg(msg1)
     120            CALL abort_gcm(modname, 'Error in iso_verif_aberrant trac: '//TRIM(err_msg), 1)
     121          END DO
     122        END DO
     123!$OMP END DO NOWAIT
     124      END DO
     125    END DO
     126  END IF
    54127
    55         !write(*,*) 'check_isotopes 52'
    56         ! verifier que l'eau normale est OK
    57         if (use_iso(1)) then
    58           ixt=indnum_fn_num(1)
    59           do phase=1,nqo
    60             iq=iqiso(ixt,phase)
    61 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    62             do k=1,llm
    63             DO i = ijb,ije 
    64               if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
    65      :          (abs((q(i,k,phase)-q(i,k,iq))/
    66      :           max(max(abs(q(i,k,phase)),abs(q(i,k,iq))),1e-18))
    67      :           .gt.errmaxrel)) then
    68                   write(*,*) 'erreur detectee par iso_verif_egalite:'
    69                   write(*,*) err_msg
    70                   write(*,*) 'ixt,phase,ijb=',ixt,phase,ijb
    71                   write(*,*) 'q,iq,i,k=',q(i,k,iq),iq,i,k
    72                   write(*,*) 'q(i,k,phase)=',q(i,k,phase)
    73                   stop
    74               endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
    75               ! bidouille pour éviter divergence:
    76               q(i,k,iq)= q(i,k,phase)
    77             enddo ! DO i = ijb,ije
    78             enddo !do k=1,llm
    79 c$OMP END DO NOWAIT
    80           enddo ! do phase=1,nqo
    81         endif !if (use_iso(1)) then
    82        
    83         !write(*,*) 'check_isotopes 78'
    84         ! verifier que HDO est raisonable
    85         if (use_iso(2)) then
    86           ixt=indnum_fn_num(2)
    87           do phase=1,nqo
    88             iq=iqiso(ixt,phase)
    89 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    90             do k=1,llm
    91             DO i = ijb,ije
    92             if (q(i,k,iq).gt.qmin) then
    93              deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(2)-1)*1000
    94              if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    95                   write(*,*) 'erreur detectee par iso_verif_aberrant:'
    96                   write(*,*) err_msg
    97                   write(*,*) 'ixt,phase=',ixt,phase
    98                   write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
    99                   write(*,*) 'q=',q(i,k,:)
    100                   write(*,*) 'deltaD=',deltaD
    101                   stop
    102              endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    103             endif !if (q(i,k,iq).gt.qmin) then
    104             enddo !DO i = ijb,ije
    105             enddo !do k=1,llm
    106 c$OMP END DO NOWAIT
    107           enddo ! do phase=1,nqo
    108         endif !if (use_iso(2)) then
     128  !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
     129  DO iiso = 1, niso
     130    DO ipha = 1, npha
     131      iq = iTraPha(iiso, ipha)
     132!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     133      DO k = 1, llm
     134        DO i = ijb, ije
     135          xiiso = q(i,k,iq)
     136          xtractot = SUM(q(i, k, iTraPha(iZonIso(1:nzon,iiso), ipha)))
     137          IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
     138            CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
     139            WRITE(msg1,'("iiso, ipha =",2i0)')iiso, ipha;              CALL msg(msg1)
     140            WRITE(msg1,'("i, k =",2i0)')i, k;                          CALL msg(msg1)
     141            WRITE(msg1,'("q(",i0,",",i0,":) = ",ES12.4)')i,k,q(i,k,:); CALL msg(msg1)
     142            STOP
     143          END IF
     144          IF(ABS(xtractot) <= ridicule) CYCLE
     145          DO izon = 1, nzon
     146            ixt = iZonIso(izon, iiso)
     147            q(i,k,iq) = q(i,k,iq) / xtractot * xiiso
     148          END DO
     149        END DO
     150      END DO
     151!$OMP END DO NOWAIT
     152    END DO
     153  END DO
    109154
    110         !write(*,*) 'check_isotopes 103'
    111         ! verifier que O18 est raisonable
    112         if (use_iso(3)) then
    113           ixt=indnum_fn_num(3)
    114           do phase=1,nqo
    115             iq=iqiso(ixt,phase)
    116 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    117             do k=1,llm
    118             DO i = ijb,ije
    119             if (q(i,k,iq).gt.qmin) then
    120              deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(3)-1)*1000
    121              if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    122                   write(*,*) 'erreur detectee iso_verif_aberrant O18:'
    123                   write(*,*) err_msg
    124                   write(*,*) 'ixt,phase=',ixt,phase
    125                   write(*,*) 'q,iq,i,k,=',q(i,k,phase),iq,i,k
    126                   write(*,*) 'xt=',q(i,k,:)
    127                   write(*,*) 'deltaO18=',deltaD
    128                   stop
    129              endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    130             endif !if (q(i,k,iq).gt.qmin) then
    131             enddo !DO i = ijb,ije
    132             enddo !do k=1,llm
    133 c$OMP END DO NOWAIT
    134           enddo ! do phase=1,nqo
    135         endif !if (use_iso(2)) then
    136 
    137 
    138         !write(*,*) 'check_isotopes 129'
    139         if (ok_isotrac) then
    140 
    141           if (use_iso(2).and.use_iso(1)) then
    142             do izone=1,ntraceurs_zone
    143              ixt=index_trac(izone,indnum_fn_num(2))
    144              ieau=index_trac(izone,indnum_fn_num(1))
    145              do phase=1,nqo
    146                iq=iqiso(ixt,phase)
    147                iqeau=iqiso(ieau,phase)
    148 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    149                do k=1,llm
    150                 DO i = ijb,ije
    151                 if (q(i,k,iq).gt.qmin) then
    152                  deltaD=(q(i,k,iq)/q(i,k,iqeau)/tnat(2)-1)*1000
    153                  if ((deltaD.gt.deltaDmax).or.
    154      &                   (deltaD.lt.deltaDmin)) then
    155                   write(*,*) 'erreur dans iso_verif_aberrant trac:'
    156                   write(*,*) err_msg
    157                   write(*,*) 'izone,phase=',izone,phase
    158                   write(*,*) 'ixt,ieau=',ixt,ieau
    159                   write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
    160                   write(*,*) 'deltaD=',deltaD
    161                   stop
    162                  endif !if ((deltaD.gt.deltaDmax).or.
    163                 endif !if (q(i,k,iq).gt.qmin) then
    164                 enddo !DO i = ijb,ije
    165                 enddo  ! do k=1,llm
    166 c$OMP END DO NOWAIT
    167               enddo ! do phase=1,nqo   
    168             enddo !do izone=1,ntraceurs_zone
    169           endif !if (use_iso(2).and.use_iso(1)) then
    170 
    171           do iiso=1,niso
    172            do phase=1,nqo
    173               iq=iqiso(iiso,phase)
    174 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    175               do k=1,llm
    176                 DO i = ijb,ije
    177                    xtractot=0.0
    178                    xiiso=q(i,k,iq)
    179                    do izone=1,ntraceurs_zone
    180                       iq=iqiso(index_trac(izone,iiso),phase)
    181                       xtractot=xtractot+ q(i,k,iq)
    182                    enddo !do izone=1,ntraceurs_zone
    183                    if ((abs(xtractot-xiiso).gt.errmax).and.
    184      :                  (abs(xtractot-xiiso)/
    185      :                  max(max(abs(xtractot),abs(xiiso)),1e-18)
    186      :                  .gt.errmaxrel)) then
    187                   write(*,*) 'erreur detectee par iso_verif_traceurs:'
    188                   write(*,*) err_msg
    189                   write(*,*) 'iiso,phase=',iiso,phase
    190                   write(*,*) 'i,k,=',i,k
    191                   write(*,*) 'q(i,k,:)=',q(i,k,:)
    192                   stop
    193                  endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
    194                  
    195                  ! bidouille pour éviter divergence:
    196                  if (abs(xtractot).gt.ridicule) then
    197                    do izone=1,ntraceurs_zone
    198                      ixt=index_trac(izone,iiso)
    199                      q(i,k,iq)=q(i,k,iq)/xtractot*xiiso
    200                    enddo !do izone=1,ntraceurs_zone               
    201                   endif !if ((abs(xtractot).gt.ridicule) then
    202                 enddo !DO i = ijb,ije
    203               enddo !do k=1,llm
    204 c$OMP END DO NOWAIT
    205            enddo !do phase=1,nqo
    206           enddo !do iiso=1,niso
    207 
    208         endif !if (ok_isotrac) then
    209 
    210         endif ! if (ok_isotopes)
    211         !write(*,*) 'check_isotopes 198'
    212        
    213         end
    214 
    215 
     155END SUBROUTINE check_isotopes

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/dynetat0_loc.F90

    r3043 r3852  
    77!-------------------------------------------------------------------------------
    88  USE parallel_lmdz
    9   USE infotrac
     9  USE infotrac, ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
    1010  USE netcdf, ONLY: NF90_OPEN,  NF90_INQUIRE_DIMENSION, NF90_INQ_VARID,        &
    1111      NF90_NOWRITE, NF90_CLOSE, NF90_INQUIRE_VARIABLE,  NF90_GET_VAR, NF90_NoErr
    … …  
    3939!===============================================================================
    4040! Local variables:
    41   CHARACTER(LEN=256) :: msg, var, modname
     41  CHARACTER(LEN=256) :: sdum, var, modname
    4242  INTEGER, PARAMETER :: length=100
    4343  INTEGER :: iq, fID, vID, idecal, ierr
    … …  
    152152  ALLOCATE(q_glo(ip1jmp1,llm))
    153153  DO iq=1,nqtot
    154     var=tname(iq)
     154    tr => tracers(iq)
     155    var = tr%name
     156    IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN
     157      CALL get_var2(var ,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
    155158#ifdef INCA
    156     IF (var .eq. "O3" ) THEN
    157        IF(NF90_INQ_VARID(fID,var,vID) == NF90_NoErr) THEN
    158           CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
    159        ELSE
    160           WRITE(lunout,*) 'Tracer O3 is missing - it is initialized to OX'
    161           IF(NF90_INQ_VARID(fID,"OX",vID) == NF90_NoErr) THEN
    162              CALL get_var2("OX",q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
    163           ENDIF
    164        ENDIF
    165     ENDIF
     159    ELSE IF(NF90_INQ_VARID(fID,"OX",vID) == NF90_NoErr .AND. var == 'O3') THEN
     160      WRITE(lunout,*) 'Tracer O3 is missing - it is initialized to OX'
     161      CALL get_var2("OX",q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
    166162#endif
    167     IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN
    168       CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
    169163    END IF
    170164    WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"
    … …  
    173167   !--- CRisi: for isotops, theoretical initialization using very simplified
    174168   !           Rayleigh distillation las.
    175     IF(ok_isotopes.AND.iso_num(iq)>0) THEN
    176       IF(zone_num(iq)==0) q(:,:,iq)=q(:,:,iqpere(iq))*tnat(iso_num(iq))        &
    177      &           *(q(:,:,iqpere(iq))/30.e-3)**(alpha_ideal(iso_num(iq))-1)
    178       IF(zone_num(iq)==1) q(:,:,iq)=q(:,:,iqiso(iso_indnum(iq),phase_num(iq)))
     169    IF(niso > 0 .AND. tr%iso_num > 0) THEN
     170      IF(tr%iso_zon == 0) q(:,:,iq) = q(:,:,tr%iprnt)         *        tnat(tr%iso_num) &
     171                                   * (q(:,:,tr%iprnt)/30.e-3)**(alpha_ideal(tr%iso_num)-1)
     172      IF(tr%iso_zon == 1) q(:,:,iq) = q(:,:,iTraPha(tr%iso_num,tr%iso_pha))
    179173    END IF
    180174  END DO
    … …  
    195189    s1='value of '//TRIM(str1)//' ='
    196190    s2=' read in starting file differs from parametrized '//TRIM(str2)//' ='
    197     WRITE(msg,'(10x,a,i4,2x,a,i4)'),s1,n1,s2,n2
    198     CALL ABORT_gcm(TRIM(modname),TRIM(msg),1)
     191    WRITE(sdum,'(10x,a,i4,2x,a,i4)'),s1,n1,s2,n2
     192    CALL ABORT_gcm(TRIM(modname),TRIM(sdum),1)
    199193  END IF
    200194END SUBROUTINE check_dim
    … …  
    246240  IF(ierr==NF90_NoERR) RETURN
    247241  SELECT CASE(typ)
    248     CASE('inq');   msg="Field <"//TRIM(nam)//"> is missing"
    249     CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
    250     CASE('open');  msg="File opening failed for <"//TRIM(nam)//">"
    251     CASE('close'); msg="File closing failed for <"//TRIM(nam)//">"
     242    CASE('inq');   sdum="Field <"//TRIM(nam)//"> is missing"
     243    CASE('get');   sdum="Reading failed for <"//TRIM(nam)//">"
     244    CASE('open');  sdum="File opening failed for <"//TRIM(nam)//">"
     245    CASE('close'); sdum="File closing failed for <"//TRIM(nam)//">"
    252246  END SELECT
    253   CALL ABORT_gcm(TRIM(modname),TRIM(msg),ierr)
     247  CALL ABORT_gcm(TRIM(modname),TRIM(sdum),ierr)
    254248END SUBROUTINE err
    255249

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/dynredem_loc.F90

    r3851 r3852  
    99  USE parallel_lmdz
    1010  USE mod_hallo
    11   USE infotrac
     11  USE infotrac, ONLY: nqtot, tracers
    1212  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
    1313                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
    … …  
    151151  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
    152152  DO iq=1,nqtot
    153     CALL cre_var(nid,tname(iq),ttext(iq),[rlonvID,rlatuID,sID,timID])
     153    CALL cre_var(nid,tracers(iq)%name(iq),tracers(iq)%lnam,[rlonvID,rlatuID,sID,timID])
    154154  END DO
    155155  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
    … …  
    174174  USE parallel_lmdz
    175175  USE mod_hallo
    176   USE infotrac
    177   USE control_mod
     176  USE infotrac, ONLY: nqtot, tracers, type_trac
    178177  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
    179178                      NF90_CLOSE, NF90_WRITE,   NF90_PUT_VAR, NF90_NoErr
    … …  
    248247
    249248!--- Save tracers
    250   DO iq=1,nqtot; var=tname(iq); ierr=-1
     249  DO iq=1,nqtot; var=tracers(iq)%name; ierr=-1
    251250    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
    252251!$OMP MASTER     

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/iniacademic_loc.F90

    r3435 r3852  
    77  use exner_hyb_m, only: exner_hyb
    88  use exner_milieu_m, only: exner_milieu
    9   USE infotrac, ONLY: nqtot,niso_possibles,ok_isotopes,iqpere,ok_iso_verif,tnat,alpha_ideal, &
    10         & iqiso,phase_num,iso_indnum,iso_num,zone_num
     9  USE infotrac, ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
    1110  USE control_mod, ONLY: day_step,planet_type
    1211  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
    … …  
    7978
    8079  REAL zdtvr
    81  
     80
     81  TYPE(tra), POINTER :: tr
     82
    8283  character(len=*),parameter :: modname="iniacademic"
    8384  character(len=80) :: abort_message
    … …  
    279280              ! CRisi: init des isotopes
    280281              ! distill de Rayleigh très simplifiée
    281               if (ok_isotopes) then
    282                 if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then         
    283                    q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqpere(i))       &
    284       &                  *tnat(iso_num(i))                             &
    285       &                  *(q(ijb_u:ije_u,:,iqpere(i))/30.e-3)                              &
    286      &                   **(alpha_ideal(iso_num(i))-1)
    287                 endif               
    288                 if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
    289                   q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqiso(iso_indnum(i),phase_num(i)))
    290                 endif
    291               endif !if (ok_isotopes) then
     282              tr => tracers(i)
     283              IF(niso > 0 .AND. tr%iso_num > 0) THEN
     284                IF(tr%iso_zon == 0) &
     285                  q(ijb_u:ije_u,:,i) = q(ijb_u:ije_u,:,tr%iprnt)         *        tnat(tr%iso_num)
     286                                     *(q(ijb_u:ije_u,:,tr%iprnt)/30.e-3)**(alpha_ideal(tr%iso_num)-1)
     287                IF(tr%iso_zon == 1) &
     288                  q(ijb_u:ije_u,:,i) = q(ijb_u:ije_u,:,iTraPha(tr%iso_num,tr%iso_pha))
     289              END IF
    292290
    293291           enddo
    … …  
    296294        endif ! of if (planet_type=="earth")
    297295
    298         if (ok_iso_verif) then
    299            call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
    300         endif !if (ok_iso_verif) then
     296        call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
    301297
    302298        ! add random perturbation to temperature

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/integrd_loc.F

    r2603 r3852  
    1111      USE write_field
    1212      USE integrd_mod
    13       USE infotrac, ONLY: ok_iso_verif ! ajout CRisi
    1413      USE comconst_mod, ONLY: pi
    1514      USE logic_mod, ONLY: leapf
    … …  
    347346c$OMP BARRIER
    348347
    349         if (ok_iso_verif) then
    350            call check_isotopes(q,ijb,ije,'integrd 342')
    351         endif !if (ok_iso_verif) then
     348        call check_isotopes(q,ijb,ije,'integrd 342')
    352349
    353350        !write(*,*) 'integrd 341'
    … …  
    355352        !write(*,*) 'integrd 343'
    356353
    357         if (ok_iso_verif) then
    358            call check_isotopes(q,ijb,ije,'integrd 346')
    359         endif !if (ok_iso_verif) then
     354        call check_isotopes(q,ijb,ije,'integrd 346')
    360355c
    361356c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
    … …  
    408403      ENDIF
    409404
    410         if (ok_iso_verif) then
    411            call check_isotopes(q,ijb,ije,'integrd 409')
    412         endif !if (ok_iso_verif) then
     405      call check_isotopes(q,ijb,ije,'integrd 409')
    413406     
    414407! Ehouarn: forget about finvmaold

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/leapfrog_loc.F

    r3666 r3852  
    2020       USE vampir
    2121       USE timer_filtre, ONLY : print_filtre_timer
    22        USE infotrac
     22       USE infotrac, ONLY: nqtot
    2323       USE guide_loc_mod, ONLY : guide_main
    2424       USE getparam
    … …  
    204204      TYPE(distrib),SAVE :: new_dist
    205205
    206       if (ok_iso_verif) then
    207          call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
    208       endif !if (ok_iso_verif) then
     206      call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
    209207     
    210208c$OMP MASTER
    … …  
    226224      itaufinp1 = itaufin +1
    227225
    228       if (ok_iso_verif) then
    229         call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
    230       endif !if (ok_iso_verif) then
     226      call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
    231227
    232228      itau = 0
    … …  
    243239      q=q0
    244240
    245       if (ok_iso_verif) then
    246         call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
    247       endif !if (ok_iso_verif) then
     241      call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
    248242     
    249243!      iday = day_ini+itau/day_step
    … …  
    324318      endif
    325319
    326         if (ok_iso_verif) then
    327            call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
    328         endif !if (ok_iso_verif) then
     320      call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
    329321
    330322#ifdef CPP_IOIPSL
    … …  
    406398
    407399
    408         if (ok_iso_verif) then
    409            call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
    410         endif !if (ok_iso_verif) then
     400        call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
    411401
    412402   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    413403
    414404
    415         if (ok_iso_verif) then
    416            call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
    417         endif !if (ok_iso_verif) then
     405        call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
    418406
    419407c$OMP MASTER
    … …  
    497485
    498486
    499         if (ok_iso_verif) then
    500            call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
    501         endif !if (ok_iso_verif) then
     487      call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
    502488
    503489!ym  PAS D'AJUSTEMENT POUR LE MOMENT     
    … …  
    618604      endif       
    619605     
    620      
    621         if (ok_iso_verif) then
    622            call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
    623         endif !if (ok_iso_verif) then
     606      call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
    624607     
    625608c-----------------------------------------------------------------------
    … …  
    683666      ! compute geopotential phi()
    684667      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    685        
    686         if (ok_iso_verif) then
    687            call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
    688         endif !if (ok_iso_verif) then
     668
     669      call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
    689670     
    690671      call VTb(VTcaldyn)
    … …  
    725706c   -------------------------------------------------------------
    726707
    727         if (ok_iso_verif) then
    728            call check_isotopes(q,ijb_u,ije_u,
     708      call check_isotopes(q,ijb_u,ije_u,
    729709     &           'leapfrog 686: avant caladvtrac')
    730         endif !if (ok_iso_verif) then
    731710     
    732711      IF( forward. OR . leapf )  THEN
    … …  
    738717
    739718         !write(*,*) 'leapfrog 719'
    740          if (ok_iso_verif) then
    741            call check_isotopes(q,ijb_u,ije_u,
     719         call check_isotopes(q,ijb_u,ije_u,
    742720     &           'leapfrog 698: apres caladvtrac')
    743          endif !if (ok_iso_verif) then
    744721
    745722!      do j=1,nqtot
    … …  
    775752
    776753       !write(*,*) 'leapfrog 720'
    777         if (ok_iso_verif) then
    778            call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
    779         endif !if (ok_iso_verif) then
     754      call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
    780755
    781756       ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
    … …  
    785760
    786761       !write(*,*) 'leapfrog 724'       
    787         if (ok_iso_verif) then
    788            call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
    789         endif !if (ok_iso_verif) then
     762      call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
    790763 
    791764!       CALL FTRACE_REGION_END("integrd")
    … …  
    802775#endif   
    803776
    804         if (ok_iso_verif) then
    805            call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
    806         endif !if (ok_iso_verif) then
     777      call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
    807778
    808779c      do j=1,nqtot
    … …  
    11641135       ENDIF ! of IF( apphys )
    11651136
    1166         if (ok_iso_verif) then
    1167            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
    1168         endif !if (ok_iso_verif) then
     1137       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
    11691138        !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
    11701139
    … …  
    12331202
    12341203cc$OMP END PARALLEL
    1235         if (ok_iso_verif) then
    1236            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
    1237         endif !if (ok_iso_verif) then
     1204        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
    12381205
    12391206c-----------------------------------------------------------------------
    … …  
    14701437c              ENDIF
    14711438
    1472         if (ok_iso_verif) then
    1473            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
    1474         endif !if (ok_iso_verif) then     
     1439      call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
    14751440 
    14761441c   ********************************************************************
    … …  
    15551520         RETURN
    15561521      ENDIF
    1557      
    1558         if (ok_iso_verif) then
    1559            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
    1560         endif !if (ok_iso_verif) then
     1522
     1523      call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
    15611524
    15621525      IF ( .NOT.purmats ) THEN
    … …  
    16451608            ENDIF
    16461609
    1647         if (ok_iso_verif) then
    16481610           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
    1649         endif !if (ok_iso_verif) then
    16501611
    16511612c-----------------------------------------------------------------------
    … …  
    16851646            ENDIF ! of IF (itau.EQ.itaufin)
    16861647
    1687         if (ok_iso_verif) then
    1688            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
    1689         endif !if (ok_iso_verif) then
     1648            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
    16901649
    16911650c-----------------------------------------------------------------------
    … …  
    17241683      ELSE ! of IF (.not.purmats)
    17251684
    1726 
    1727         if (ok_iso_verif) then
    1728            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
    1729         endif !if (ok_iso_verif) then
     1685        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
    17301686
    17311687c       ........................................................
    … …  
    17711727            ELSE ! of IF(forward) i.e. backward step
    17721728
    1773              
    1774         if (ok_iso_verif) then
    1775            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
    1776         endif !if (ok_iso_verif) then 
     1729              call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
    17771730
    17781731              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
    … …  
    18341787            ENDIF ! of IF (forward)
    18351788
    1836 
    1837         if (ok_iso_verif) then
    1838            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
    1839         endif !if (ok_iso_verif) then
     1789            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
    18401790
    18411791      END IF ! of IF(.not.purmats)

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/massbarxy_loc.F90

    r2597 r3852  
    2727    DO ij=ijb,ije-1
    2828      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
    29      +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
    30      +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
    31      +               masse(ij+iip2,l)*alpha4(ij+iip2)
     29                     masse(ij+1   ,l)*alpha3(ij+1   ) + &
     30                     masse(ij+iip1,l)*alpha1(ij+iip1) + &
     31                     masse(ij+iip2,l)*alpha4(ij+iip2)
    3232    END DO
    3333    DO ij=ijb+iip1-1,ije+iip1-1,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/qminimum_loc.F

    r3851 r3852  
    44      SUBROUTINE qminimum_loc( q,nqtot,deltap )
    55      USE parallel_lmdz
    6       USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif,             &
    7      &   ratiomin,qperemin ! CRisi 23nov2020
     6      USE infotrac, ONLY: nitr, iTraPha, qperemin ! CRisi 23nov2020
    87      IMPLICIT none
    98c
    … …  
    5554
    5655        !write(lunout,*) 'qminimum 52: entree'
    57         if (ok_iso_verif) then
    58            call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
    59         endif !if (ok_iso_verif) then     
     56        call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
    6057
    6158      ijb=ij_begin
    … …  
    6966      DO 1000 k = 1, llm
    7067      DO 1040 i = ijb, ije
    71             if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
    72 
    73               if (ok_isotopes) then
    74                  zx_defau_diag(i,k,iq_liq)=AMAX1
    75      :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
    76               endif !if (ok_isotopes) then
    77 
    78                q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
    79                q(i,k,iq_liq) = seuil_liq
    80             endif
     68         if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
     69
     70           if (nitr > 0) zx_defau_diag(i,k,iq_liq) =
     71     &          AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 )
     72
     73           q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
     74           q(i,k,iq_liq) = seuil_liq
     75         endif
    8176 1040 CONTINUE
    8277 1000 CONTINUE
    … …  
    10095         if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
    10196
    102             if (ok_isotopes) then
    103               zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
    104             endif !if (ok_isotopes) then
     97            if (nitr > 0) zx_defau_diag(i,k,iq) =
     98     &           AMAX1( seuil_vap - q(i,k,iq), 0.0 )
    10599
    106100            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
    … …  
    141135
    142136      !write(lunout,*) 'qminimum 128'
    143       if (ok_isotopes) then
     137      if (nitr > 0) then
    144138              !write(lunout,*) 'qminimum 140'
    145139      ! CRisi: traiter de même les traceurs d'eau
    … …  
    180174                call abort_gcm("qminimum","not enough vapor",1)
    181175              endif 
    182             do ixt=1,ntraciso
     176            do ixt=1,nitr
    183177!                write(lunout,*) 'qmin 168: ixt=',ixt
    184 !                write(lunout,*) 'q(i,k,iqiso(ixt,iq_vap)=',
    185 !     :             q(i,k,iqiso(ixt,iq_vap))
     178!                write(lunout,*) 'q(i,k,iTraPha(ixt,iq_vap)=',
     179!     :             q(i,k,iTraPha(ixt,iq_vap))
    186180!                write(lunout,*) 'zx_defau_diag(i,k,iq_vap)=',
    187181!     :                  zx_defau_diag(i,k,iq_vap)
    188 !                write(lunout,*) 'q(i,k-1,iqiso(ixt,iq_vap)=',
    189 !     :                   q(i,k-1,iqiso(ixt,iq_vap))     
    190 
    191                q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     182!                write(lunout,*) 'q(i,k-1,iTraPha(ixt,iq_vap)=',
     183!     :                   q(i,k-1,iTraPha(ixt,iq_vap))     
     184
     185               q(i,k,iTraPha(ixt,iq_vap))=q(i,k,iTraPha(ixt,iq_vap))
    192186     :              +zx_defau_diag(i,k,iq_vap)
    193      :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     187     :              *q(i,k-1,iTraPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
    194188               
    195               if (ok_iso_verif) then
    196                 if (iso_verif_noNaN_nostop(q(i,k,iqiso(ixt,iq_vap)),
    197      :                   'qminimum 155').eq.1) then
     189               if (iso_verif_noNaN_nostop(q(i,k,iTraPha(ixt,iq_vap)),
     190     :                   'qminimum 155')) then
    198191                   write(*,*) 'i,k,ixt=',i,k,ixt
    199192                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
    200193     :                   q_follow(i,k-1,iq_vap)
    201                    write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
    202      :                   q(i,k,iqiso(ixt,iq_vap))
     194                   write(*,*) 'q(i,k,iTraPha(ixt,iq_vap))=',
     195     :                   q(i,k,iTraPha(ixt,iq_vap))
    203196                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
    204197     :                   zx_defau_diag(i,k,iq_vap)
    205                    write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
    206      :                   q(i,k-1,iqiso(ixt,iq_vap))
     198                   write(*,*) 'q(i,k-1,iTraPha(ixt,iq_vap))=',
     199     :                   q(i,k-1,iTraPha(ixt,iq_vap))
    207200                   stop
    208                 endif
    209               endif
     201               endif
    210202
    211203              ! et on la retranche en k-1
    212                q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
     204               q(i,k-1,iTraPha(ixt,iq_vap))=q(i,k-1,iTraPha(ixt,iq_vap))
    213205     :              -zx_defau_diag(i,k,iq_vap)
    214206     :              *deltap(i,k)/deltap(i,k-1)
    215      :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
    216 
    217                if (ok_iso_verif) then
    218                 if (iso_verif_noNaN_nostop(q(i,k-1,iqiso(ixt,iq_vap)),
    219      :                   'qminimum 175').eq.1) then
     207     :              *q(i,k-1,iTraPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     208
     209               if (iso_verif_noNaN_nostop(q(i,k-1,iTraPha(ixt,iq_vap)),
     210     :                   'qminimum 175')) then
    220211                   write(*,*) 'k,i,ixt=',k,i,ixt
    221212                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
    222213     :                   q_follow(i,k-1,iq_vap)
    223                    write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
    224      :                   q(i,k,iqiso(ixt,iq_vap))
     214                   write(*,*) 'q(i,k,iTraPha(ixt,iq_vap))=',
     215     :                   q(i,k,iTraPha(ixt,iq_vap))
    225216                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
    226217     :                   zx_defau_diag(i,k,iq_vap)
    227                    write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
    228      :                   q(i,k-1,iqiso(ixt,iq_vap))
     218                   write(*,*) 'q(i,k-1,iTraPha(ixt,iq_vap))=',
     219     :                   q(i,k-1,iTraPha(ixt,iq_vap))
    229220                   stop
    230                 endif
    231               endif
    232 
    233               enddo !do ixt=1,niso
     221               endif
     222
     223              enddo !do ixt=1,nitr
    234224              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
    235225     :               +zx_defau_diag(i,k,iq_vap)
    … …  
    242232        enddo !do k=2,llm
    243233
    244         if (ok_iso_verif) then
    245            call check_isotopes(q,ijb,ije,'qminimum 168')
    246         endif !if (ok_iso_verif) then
     234        call check_isotopes(q,ijb,ije,'qminimum 168')
    247235       
    248236     
    … …  
    255243
    256244              ! on ajoute eau liquide en k en k             
    257               do ixt=1,ntraciso
    258                q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
     245              do ixt=1,nitr
     246               q(i,k,iTraPha(ixt,iq_liq))=q(i,k,iTraPha(ixt,iq_liq))
    259247     :              +zx_defau_diag(i,k,iq_liq)
    260      :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
     248     :              *q(i,k,iTraPha(ixt,iq_vap))/q_follow(i,k,iq_vap)
    261249              ! et on la retranche à la vapeur en k
    262                q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     250               q(i,k,iTraPha(ixt,iq_vap))=q(i,k,iTraPha(ixt,iq_vap))
    263251     :              -zx_defau_diag(i,k,iq_liq)
    264      :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
    265               enddo !do ixt=1,niso
     252     :              *q(i,k,iTraPha(ixt,iq_vap))/q_follow(i,k,iq_vap)   
     253              enddo !do ixt=1,nitr
    266254              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
    267255     :               +zx_defau_diag(i,k,iq_liq)
    … …  
    273261       enddo !do k=2,llm 
    274262
    275         if (ok_iso_verif) then
    276            call check_isotopes(q,ijb,ije,'qminimum 197')
    277         endif !if (ok_iso_verif) then
    278 
    279       endif !if (ok_isotopes) then
     263       call check_isotopes(q,ijb,ije,'qminimum 197')
     264
     265      endif !if (nitr > 0)
    280266      !write(*,*) 'qminimum 188'
    281267c

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/vlsplt_loc.F

    r3851 r3852  
    1414c   --------------------------------------------------------------------
    1515      USE parallel_lmdz
    16       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils, ! CRisi                 &
     16      USE infotrac, ONLY : nqtot,tracers, tra,        ! CRisi                 &
    1717     &                     qperemin,masseqmin,ratiomin ! MVals et CRisi
    1818      IMPLICIT NONE
    … …  
    4444
    4545      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    46       INTEGER ifils,iq2 ! CRisi
     46      INTEGER ichld,iq2 ! CRisi
     47      TYPE(tra), POINTER :: tr
    4748
    4849      Logical extremum
    … …  
    5455
    5556      INTEGER ijb,ije,ijb_x,ije_x
    56      
     57
     58      tr => tracers(iq)
     59
    5760      !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
    5861!     &   iq,ijb_x
    … …  
    330333! Il faut faire ça avant d'avoir mis à jour q et masse
    331334
    332        if (nqfils(iq).gt.0) then
    333        do ifils=1,nqdesc(iq)
    334        !do ifils=1,nqfils(iq) ! modif C Risi 22nov2020
     335       if (tr%ndesc > 0) then
     336       do ichld=1,tr%ndesc
     337       !do ichld=1,tr%nchld ! modif C Risi 22nov2020
    335338        ! attention: comme Ratio est utilisé comme q dans l'appel
    336339        ! recursif, il doit contenir à lui seul tous les indices de tous
    337340        ! les descendants!
    338          iq2=iqfils(ifils,iq)
     341         iq2=tr%idesc(ichld)
    339342c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    340343         DO l=1,llm
    … …  
    352355         enddo
    353356c$OMP END DO NOWAIT
    354         enddo !do ifils=1,nqdesc(iq)
    355         do ifils=1,nqfils(iq)
    356          iq2=iqfils(ifils,iq)
     357        enddo !do ichld=1,tr%ndesc
     358        do ichld=1,tr%nchld
     359         iq2=tr%idesc(ichld)
    357360         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
    358         enddo !do ifils=1,nqfils(iq)
    359       endif !if (nqfils(iq).gt.0) then
     361        enddo !do ichld=1,tr%nchld
     362      endif !if (tr%ndesc > 0) then
    360363! end CRisi
    361364
    … …  
    383386      ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
    384387      ! puis on boucle en longitude
    385       if (nqfils(iq).gt.0) then 
    386        do ifils=1,nqdesc(iq)
    387        !do ifils=1,nqfils(iq) ! modif C Risi 22nov2020
    388          iq2=iqfils(ifils,iq) 
     388      if (tr%ndesc > 0) then 
     389       do ichld=1,tr%ndesc
     390       !do ichld=1,tr%nchld ! modif C Risi 22nov2020
     391         iq2=tr%idesc(ichld) 
    389392c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    390393         DO l=1,llm
    … …  
    397400         enddo !DO l=1,llm
    398401c$OMP END DO NOWAIT
    399         enddo !do ifils=1,nqdesc(iq)
    400       endif !if (nqfils(iq).gt.0) then
     402        enddo !do ichld=1,tr%ndesc
     403      endif !if (tr%ndesc > 0) then
    401404
    402405      !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
    … …  
    422425c   --------------------------------------------------------------------
    423426      USE parallel_lmdz
    424       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils, ! CRisi                 &
     427      USE infotrac, ONLY : nqtot, tracers, tra,        ! CRisi                 &
    425428     &                     qperemin,masseqmin,ratiomin ! MVals et CRisi   
    426429      USE comconst_mod, ONLY: pi
    … …  
    468471
    469472      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    470       INTEGER ifils,iq2 ! CRisi
     473      INTEGER ichld,iq2 ! CRisi
     474      TYPE(tra), POINTER :: tr
    471475c
    472476c
    … …  
    478482      INTEGER ijb,ije
    479483      INTEGER ijbm,ijem
     484
     485      tr => tracers(iq)
    480486
    481487      ijb=ij_begin-2*iip1
    … …  
    732738! CRisi: appel récursif de l'advection sur les fils.
    733739! Il faut faire ça avant d'avoir mis à jour q et masse
    734       !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq)
     740      !write(*,*) 'vly 689: iq,tr%nchld=',iq,tr%nchld
    735741
    736742      ijb=ij_begin-2*iip1
    … …  
    743749      if (pole_sud)  ijem=ij_end
    744750
    745       if (nqfils(iq).gt.0) then 
    746        do ifils=1,nqdesc(iq)
    747        !do ifils=1,nqfils(iq) ! modif C Risi 22nov2020
    748          iq2=iqfils(ifils,iq)
     751      if (tr%ndesc > 0) then 
     752       do ichld=1,tr%ndesc
     753       !do ichld=1,tr%nchld ! modif C Risi 22nov2020
     754         iq2=tr%idesc(ichld)
    749755c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    750756         DO l=1,llm
    … …  
    767773         enddo !DO l=1,llm
    768774c$OMP END DO NOWAIT
    769         enddo !do ifils=1,nqdesc(iq)
    770 
    771         do ifils=1,nqfils(iq)
    772          iq2=iqfils(ifils,iq)
     775        enddo !do ichld=1,tr%ndesc
     776
     777        do ichld=1,tr%nchld
     778         iq2=tr%idesc(ichld)
    773779         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
    774         enddo !do ifils=1,nqfils(iq)
    775       endif !if (nqfils(iq).gt.0) then
     780        enddo !do ichld=1,tr%nchld
     781      endif !if (tr%ndesc > 0) then
    776782! end CRisi
    777783     
    … …  
    862868!      if (pole_sud)  ije=ij_end
    863869
    864       if (nqfils(iq).gt.0) then 
    865        do ifils=1,nqdesc(iq)
    866          iq2=iqfils(ifils,iq) 
     870      if (tr%ndesc > 0) then 
     871       do ichld=1,tr%ndesc
     872         iq2=tr%idesc(ichld) 
    867873c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    868874         DO l=1,llm
    … …  
    872878         enddo
    873879c$OMP END DO NOWAIT
    874         enddo !do ifils=1,nqdesc(iq)
    875       endif !if (nqfils(iq).gt.0) then
     880        enddo !do ichld=1,tr%ndesc
     881      endif !if (tr%ndesc > 0) then
    876882
    877883
    … …  
    895901      USE parallel_lmdz
    896902      USE vlz_mod
    897       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils, ! CRisi                 &
     903      USE infotrac, ONLY : nqtot, tracers, tra,        ! CRisi                 &
    898904     &                     qperemin,masseqmin,ratiomin ! MVals et CRisi
    899905     
    … …  
    946952      ! Ces varibles doivent être déclarées en pointer et en save dans
    947953      ! vlz_loc si on veut qu'elles soient vues par tous les threads. 
    948       INTEGER ifils,iq2 ! CRisi
     954      INTEGER ichld,iq2 ! CRisi
    949955
    950956
    … …  
    11591165! CRisi: appel récursif de l'advection sur les fils.
    11601166! Il faut faire ça avant d'avoir mis à jour q et masse
    1161       !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
    1162       if (nqfils(iq).gt.0) then 
    1163        do ifils=1,nqdesc(iq)
    1164        !do ifils=1,nqfils(iq) ! modif C Risi 22 nov 2020
    1165          iq2=iqfils(ifils,iq)
     1167      !write(*,*) 'vlsplt 942: iq,tr%nchld=',iq,tr%nchld
     1168      if (tr%ndesc > 0) then 
     1169       do ichld=1,tr%ndesc
     1170       !do ichld=1,tr%nchld ! modif C Risi 22 nov 2020
     1171         iq2=tr%idesc(ichld)
    11661172c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    11671173         DO l=1,llm
    … …  
    11791185         enddo
    11801186c$OMP END DO NOWAIT
    1181         enddo !do ifils=1,nqdesc(iq)
     1187        enddo !do ichld=1,tr%ndesc
    11821188c$OMP BARRIER
    11831189
    1184         do ifils=1,nqfils(iq)
    1185          iq2=iqfils(ifils,iq)
     1190        do ichld=1,tr%nchld
     1191         iq2=tr%idesc(ichld)
    11861192         call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
    1187         enddo !do ifils=1,nqfils(iq)
    1188       endif !if (nqfils(iq).gt.0) then
     1193        enddo !do ichld=1,tr%nchld
     1194      endif !if (tr%ndesc > 0) then
    11891195! end CRisi 
    11901196
    … …  
    12071213     
    12081214! retablir les fils en rapport de melange par rapport a l'air:
    1209       if (nqfils(iq).gt.0) then 
    1210        do ifils=1,nqdesc(iq)
    1211          iq2=iqfils(ifils,iq) 
     1215      if (tr%ndesc > 0) then 
     1216       do ichld=1,tr%ndesc
     1217         iq2=tr%idesc(ichld) 
    12121218c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    12131219         DO l=1,llm
    … …  
    12171223         enddo
    12181224c$OMP END DO NOWAIT
    1219         enddo !do ifils=1,nqdesc(iq)
    1220       endif !if (nqfils(iq).gt.0) then
     1225        enddo !do ichld=1,tr%ndesc
     1226      endif !if (tr%ndesc > 0) then
    12211227
    12221228      RETURN

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/vlspltgen_loc.F90

    r3850 r3852  
     1SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv,pdt,p,pk,teta)
     2
     3!  Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
    14!
    2 ! $Header$
     5! ********************************************************************
     6!       Shema  d'advection " pseudo amont " .
     7!   + test sur humidite specifique: Q advecte< Qsat aval
     8!               (F. Codron, 10/99)
     9! ********************************************************************
     10!  q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    311!
    4        SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv,
    5      &                           pdt, p,pk,teta                 )
    6      
    7 c
    8 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
    9 c
    10 c    ********************************************************************
    11 c          Shema  d'advection " pseudo amont " .
    12 c      + test sur humidite specifique: Q advecte< Qsat aval
    13 c                   (F. Codron, 10/99)
    14 c    ********************************************************************
    15 c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    16 c
    17 c     pente_max facteur de limitation des pentes: 2 en general
    18 c                                                0 pour un schema amont
    19 c     pbaru,pbarv,w flux de masse en u ,v ,w
    20 c     pdt pas de temps
    21 c
    22 c     teta temperature potentielle, p pression aux interfaces,
    23 c     pk exner au milieu des couches necessaire pour calculer Qsat
    24 c   --------------------------------------------------------------------
    25       USE parallel_lmdz
    26       USE mod_hallo
    27       USE Write_Field_loc
    28       USE VAMPIR
    29       ! CRisi: on rajoute variables utiles d'infotrac 
    30       USE infotrac, ONLY : nqtot,nqperes,nqdesc,nqfils,iqfils,
    31      &    ok_iso_verif
    32       USE vlspltgen_mod
    33       USE comconst_mod, ONLY: cpp
    34       IMPLICIT NONE
    35 
    36 c
    37       include "dimensions.h"
    38       include "paramet.h"
    39 
    40 c
    41 c   Arguments:
    42 c   ----------
    43       INTEGER iadv(nqtot)
    44       REAL masse(ijb_u:ije_u,llm),pente_max
    45       REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
    46       REAL q(ijb_u:ije_u,llm,nqtot)
    47       REAL w(ijb_u:ije_u,llm),pdt
    48       REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
    49       REAL pk(ijb_u:ije_u,llm)
    50 c
    51 c      Local
    52 c   ---------
    53 c
    54       INTEGER ij,l
    55 c
    56       REAL zzpbar, zzw
    57 
    58       REAL qmin,qmax
    59       DATA qmin,qmax/0.,1.e33/
    60 
    61 c--pour rapport de melange saturant--
    62 
    63       REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
    64       REAL ptarg,pdelarg,foeew,zdelta
    65       REAL tempe(ijb_u:ije_u)
    66       INTEGER ijb,ije,iq,iq2,ifils
    67       LOGICAL, SAVE :: firstcall=.TRUE.
     12!  pente_max facteur de limitation des pentes: 2 en general
     13!                                            0 pour un schema amont
     14!  pbaru,pbarv,w flux de masse en u ,v ,w
     15!  pdt pas de temps
     16!
     17!  teta temperature potentielle, p pression aux interfaces,
     18!  pk exner au milieu des couches necessaire pour calculer Qsat
     19!--------------------------------------------------------------------
     20  USE parallel_lmdz
     21  USE mod_hallo
     22  USE Write_Field_loc
     23  USE VAMPIR
     24  USE infotrac, ONLY : nqtot, tracers, tra
     25  USE vlspltgen_mod
     26  USE comconst_mod, ONLY: cpp
     27  IMPLICIT NONE
     28
     29  include "dimensions.h"
     30  include "paramet.h"
     31
     32!
     33! Arguments:
     34!----------
     35  REAL, DIMENSION(ijb_u:ije_u,llm,nqtot), INTENT(INOUT) :: q
     36  INTEGER, DIMENSION(nqtot),              INTENT(IN)    :: iadv
     37  REAL,                                   INTENT(IN)    :: pdt, pente_max
     38  REAL, DIMENSION(ijb_u:ije_u,llm),       INTENT(IN)    :: pk, pbaru, masse, w, teta
     39  REAL, DIMENSION(ijb_v:ije_v,llm),       INTENT(IN)    ::     pbarv
     40  REAL, DIMENSION(ijb_u:ije_u,llmp1),     INTENT(IN)    :: p
     41!
     42! Local
     43!---------
     44  INTEGER :: ij, l
     45  REAL    :: zzpbar, zzw
     46  REAL, PARAMETER :: qmin = 0., qmax = 1.e33
     47  TYPE(tra), POINTER :: tr
     48
     49!--pour rapport de melange saturant--
     50  REAL, PARAMETER ::   &
     51    r2es  = 380.11733, &
     52    r3les = 17.269,    &
     53    r3ies = 21.875,    &
     54    r4les = 35.86,     &
     55    r4ies = 7.66,      &
     56    retv  = 0.6077667, &
     57    rtt   = 273.16
     58
     59  REAL    :: play, ptarg, pdelarg, foeew, zdelta, tempe(ijb_u:ije_u)
     60  INTEGER :: ijb,ije,iq,iq2,ichld
     61  LOGICAL, SAVE :: firstcall=.TRUE.
    6862!$OMP THREADPRIVATE(firstcall)
    69       type(request),SAVE :: MyRequest1
    70 !$OMP THREADPRIVATE(MyRequest1)
    71       type(request),SAVE :: MyRequest2
    72 !$OMP THREADPRIVATE(MyRequest2)
    73 c    fonction psat(T)
    74 
    75        FOEEW ( PTARG,PDELARG ) = EXP (
    76      *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
    77      * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
    78 
    79         r2es  = 380.11733
    80         r3les = 17.269
    81         r3ies = 21.875
    82         r4les = 35.86
    83         r4ies = 7.66
    84         retv = 0.6077667
    85         rtt  = 273.16
    86 
    87 c Allocate variables depending on dynamic variable nqtot
    88 
    89          IF (firstcall) THEN
    90             firstcall=.FALSE.
    91          END IF
    92 c-- Calcul de Qsat en chaque point
    93 c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
    94 c   pour eviter une exponentielle.
    95 
    96       call SetTag(MyRequest1,100)
    97       call SetTag(MyRequest2,101)
    98 
     63  TYPE(request), SAVE :: MyRequest1, MyRequest2
     64!$OMP THREADPRIVATE     (MyRequest1, MyRequest2)
     65
     66!    fonction psat(T)
     67  FOEEW ( PTARG,PDELARG ) = EXP ( (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) &
     68                         / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
     69
     70! Allocate variables depending on dynamic variable nqtot
     71  IF(firstcall) THEN
     72     firstcall=.FALSE.
     73  END IF
     74!-- Calcul de Qsat en chaque point
     75!-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
     76!   pour eviter une exponentielle.
     77
     78  CALL SetTag(MyRequest1,100)
     79  CALL SetTag(MyRequest2,101)
     80
     81  ijb=ij_begin-iip1; IF(pole_nord) ijb=ij_begin
     82  ije=ij_end  +iip1; IF(pole_sud)  ije=ij_end
     83
     84!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     85  DO l = 1, llm
     86    DO ij = ijb, ije
     87      tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
     88    END DO
     89    DO ij = ijb, ije
     90      zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
     91      play   = 0.5*(p(ij,l)+p(ij,l+1))
     92      qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
     93      qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
     94    END DO
     95  END DO
     96!$OMP END DO NOWAIT
     97!     PRINT*,'Debut vlsplt version debug sans vlyqs'
     98
     99  zzpbar = 0.5 * pdt
     100  zzw    = pdt
     101
     102  ijb=ij_begin; IF(pole_nord) ijb=ijb+iip1
     103  ije=ij_end;   IF(pole_sud)  ije=ije-iip1
     104!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
     105  DO l=1,llm
     106    DO ij = ijb,ije
     107      mu(ij,l)=pbaru(ij,l) * zzpbar
     108    END DO
     109  END DO
     110!$OMP END DO NOWAIT
     111     
     112  ijb=ij_begin-iip1; IF(pole_nord) ijb=ij_begin
     113  ije=ij_end;        IF(pole_sud)  ije=ij_end-iip1
     114!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     115  DO l=1,llm
     116    DO ij=ijb,ije
     117      mv(ij,l)=pbarv(ij,l) * zzpbar
     118    END DO
     119  END DO
     120!$OMP END DO NOWAIT
     121
     122  ijb=ij_begin
     123  ije=ij_end
     124  DO iq=1,nqtot
     125!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
     126    DO l=1,llm
     127      DO ij=ijb,ije
     128        mw(ij,l,iq)=w(ij,l) * zzw
     129      END DO
     130    END DO
     131!$OMP END DO NOWAIT
     132  END DO
     133
     134  DO iq=1,nqtot 
     135!$OMP MASTER
     136    DO ij=ijb,ije
     137      mw(ij,llm+1,iq)=0.
     138    END DO
     139!$OMP END MASTER
     140  END DO
     141
     142!  CALL SCOPY(ijp1llm,q,1,zq,1)
     143!  CALL SCOPY(ijp1llm,masse,1,zm,1)
     144
     145  ijb=ij_begin
     146  ije=ij_end
     147  DO iq=1,nqtot       
     148!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     149    DO l=1,llm
     150      zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
     151      zm(ijb:ije,l,iq)=masse(ijb:ije,l)
     152    END DO
     153!$OMP END DO NOWAIT
     154  END DO
     155
     156#ifdef DEBUG_IO     
     157  CALL WriteField_u('mu',mu)
     158  CALL WriteField_v('mv',mv)
     159  CALL WriteField_u('mw',mw)
     160  CALL WriteField_u('qsat',qsat)
     161#endif
     162
     163  ! verif temporaire
     164  ijb=ij_begin
     165  ije=ij_end 
     166  CALL check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
     167
     168!$OMP BARRIER           
     169  DO iq=1,nqtot
     170    tr => tracers(iq)
     171    ! CRisi: on ne boucle que sur les parents = ceux qui sont transportes directement par l'air
     172    IF(tr%igen /= 1) CYCLE
     173!    write(*,*) 'vlspltgen 192: iq,iadv=',iq,iadv(iq)
     174#ifdef DEBUG_IO   
     175    CALL WriteField_u('zq',zq(:,:,iq))
     176    CALL WriteField_u('zm',zm(:,:,iq))
     177#endif
     178    !----------------------------------------------------------------------
     179    SELECT CASE(iadv(iq))
     180    !----------------------------------------------------------------------
     181      CASE(0); CYCLE
     182    !----------------------------------------------------------------------
     183      CASE(10)
     184#ifdef _ADV_HALO       
     185        ! CRisi: on ajoute les nombres de fils et tableaux des fils
     186        ! On suppose qu'on ne peut advecter les fils que par le schéma 10. 
     187        CALL vlx_loc(zq,pente_max,zm,mu,ij_begin,ij_begin+2*iip1-1,iq)
     188        CALL vlx_loc(zq,pente_max,zm,mu,ij_end-2*iip1+1,ij_end,iq)
     189#else
     190        CALL vlx_loc(zq,pente_max,zm,mu,ij_begin,ij_end,iq)
     191#endif
     192!$OMP MASTER
     193        CALL VTb(VTHallo)
     194!$OMP END MASTER
     195        CALL Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
     196        CALL Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
     197! CRisi
     198        DO ichld=1,tr%ndesc
     199          iq2=tr%idesc(ichld)
     200          CALL Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
     201          CALL Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
     202        END DO
     203!$OMP MASTER
     204        CALL VTe(VTHallo)
     205!$OMP END MASTER
     206    !----------------------------------------------------------------------
     207      CASE(14)
     208#ifdef _ADV_HALO           
     209        CALL vlxqs_loc(zq,pente_max,zm,mu,qsat,ij_begin,ij_begin+2*iip1-1,iq)
     210        CALL vlxqs_loc(zq,pente_max,zm,mu,qsat,ij_end-2*iip1+1,ij_end,iq)
     211#else
     212        CALL vlxqs_loc(zq,pente_max,zm,mu,qsat,ij_begin,ij_end,iq)
     213#endif
     214!$OMP MASTER
     215        CALL VTb(VTHallo)
     216!$OMP END MASTER
     217        CALL Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
     218        CALL Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
     219        DO ichld=1,tr%ndesc
     220          iq2=tr%idesc(ichld)
     221          CALL Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
     222          CALL Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
     223        END DO
     224!$OMP MASTER
     225        CALL VTe(VTHallo)
     226!$OMP END MASTER
     227    !----------------------------------------------------------------------
     228      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     229    !----------------------------------------------------------------------
     230    END SELECT
     231    !----------------------------------------------------------------------
     232  END DO
     233!$OMP BARRIER     
     234
     235!$OMP MASTER     
     236  CALL VTb(VTHallo)
     237!$OMP END MASTER
     238  CALL SendRequest(MyRequest1)
     239!$OMP MASTER
     240  CALL VTe(VTHallo)
     241!$OMP END MASTER       
     242
     243!$OMP BARRIER
     244
     245  ! verif temporaire
     246  ijb=ij_begin-2*iip1; IF(pole_nord) ijb=ij_begin
     247  ije=ij_end  +2*iip1; IF(pole_sud)  ije=ij_end
     248  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
     249
     250  DO iq=1,nqtot
     251    tr => tracers(iq)
     252!    write(*,*) 'vlspltgen 279: iq=',iq
     253    IF(tr%igen /= 1) CYCLE
     254    !----------------------------------------------------------------------
     255    SELECT CASE(iadv(iq))
     256    !----------------------------------------------------------------------
     257      CASE(0); CYCLE
     258    !----------------------------------------------------------------------
     259      CASE(10)
     260#ifdef _ADV_HALLO
     261        CALL vlx_loc(zq,pente_max,zm,mu,ij_begin+2*iip1,ij_end-2*iip1,iq)
     262#endif
     263    !----------------------------------------------------------------------
     264      CASE(14)
     265#ifdef _ADV_HALLO
     266        CALL vlxqs_loc(zq,pente_max,zm,mu,qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
     267#endif
     268      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     269    !----------------------------------------------------------------------
     270    END SELECT
     271    !----------------------------------------------------------------------
     272  END DO
     273!$OMP BARRIER     
     274
     275!$OMP MASTER
     276  CALL VTb(VTHallo)
     277!$OMP END MASTER
     278
     279!  CALL WaitRecvRequest(MyRequest1)
     280!  CALL WaitSendRequest(MyRequest1)
     281!$OMP BARRIER
     282  CALL WaitRequest(MyRequest1)
     283
     284
     285!$OMP MASTER
     286  CALL VTe(VTHallo)
     287!$OMP END MASTER
     288!$OMP BARRIER
     289
     290  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
     291
     292  ijb=ij_begin-2*iip1; IF(pole_nord) ijb=ij_begin
     293  ije=ij_end  +2*iip1; IF(pole_sud)  ije=ij_end
     294
     295  CALL check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
     296
     297  DO iq=1,nqtot
     298    tr => tracers(iq)
     299!    write(*,*) 'vlspltgen 321: iq=',iq
     300    IF(tr%igen /= 1) CYCLE
     301#ifdef DEBUG_IO   
     302    CALL WriteField_u('zq',zq(:,:,iq))
     303    CALL WriteField_u('zm',zm(:,:,iq))
     304#endif
     305    !----------------------------------------------------------------------
     306    SELECT CASE(iadv(iq))
     307      CASE(0); CYCLE
     308      CASE(10); CALL   vly_loc(zq,pente_max,zm,mv,iq)
     309      CASE(14); CALL vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
     310      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     311    END SELECT
     312    !----------------------------------------------------------------------
     313  END DO
     314
     315  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
     316
     317  DO iq=1,nqtot
     318    tr => tracers(iq)
     319!    write(*,*) 'vlspltgen 349: iq=',iq
     320    IF(tr%igen /= 1) CYCLE
     321#ifdef DEBUG_IO   
     322    CALL WriteField_u('zq',zq(:,:,iq))
     323    CALL WriteField_u('zm',zm(:,:,iq))
     324#endif
     325    !----------------------------------------------------------------------
     326    SELECT CASE(iadv(iq))
     327    !----------------------------------------------------------------------
     328      CASE(0); CYCLE
     329    !----------------------------------------------------------------------
     330      CASE(10,14)
     331!$OMP BARRIER       
     332#ifdef _ADV_HALLO
     333        CALL vlz_loc(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1,iq)
     334        CALL vlz_loc(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end,iq)
     335#else
     336        CALL vlz_loc(zq,pente_max,zm,mw,ij_begin,ij_end,iq)
     337#endif
     338!$OMP BARRIER
     339!$OMP MASTER
     340        CALL VTb(VTHallo)
     341!$OMP END MASTER
     342        CALL Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
     343        CALL Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
     344        ! CRisi
     345        DO ichld=1,tr%ndesc
     346          iq2=tr%idesc(ichld)
     347          CALL Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
     348          CALL Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
     349        END DO
     350!$OMP MASTER
     351        CALL VTe(VTHallo)
     352!$OMP END MASTER       
     353!$OMP BARRIER
     354    !----------------------------------------------------------------------
     355      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     356    !----------------------------------------------------------------------
     357    END SELECT
     358    !----------------------------------------------------------------------
     359  END DO
     360!$OMP BARRIER     
     361
     362
     363!$OMP MASTER       
     364  CALL VTb(VTHallo)
     365!$OMP END MASTER
     366
     367  CALL SendRequest(MyRequest2)
     368
     369!$OMP MASTER
     370  CALL VTe(VTHallo)
     371!$OMP END MASTER       
     372
     373  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
     374
     375!$OMP BARRIER
     376  DO iq=1,nqtot
     377    tr => tracers(iq)
     378!    write(*,*) 'vlspltgen 409: iq=',iq
     379    IF(tr%igen /= 1) CYCLE
     380    !----------------------------------------------------------------------
     381    SELECT CASE(iadv(iq))
     382    !----------------------------------------------------------------------
     383      CASE(0); CYCLE
     384    !----------------------------------------------------------------------
     385      CASE(10,14)
     386!$OMP BARRIER       
     387#ifdef _ADV_HALLO
     388        CALL vlz_loc(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1,iq)
     389#endif
     390!$OMP BARRIER
     391    !----------------------------------------------------------------------
     392      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     393    !----------------------------------------------------------------------
     394    END SELECT
     395    !----------------------------------------------------------------------
     396  END DO
     397!  write(*,*) 'vlspltgen_loc 476'
     398
     399!$OMP BARRIER
     400!  write(*,*) 'vlspltgen_loc 477'
     401!$OMP MASTER
     402  CALL VTb(VTHallo)
     403!$OMP END MASTER
     404
     405!  CALL WaitRecvRequest(MyRequest2)
     406!  CALL WaitSendRequest(MyRequest2)
     407!$OMP BARRIER
     408  CALL WaitRequest(MyRequest2)
     409
     410!$OMP MASTER
     411  CALL VTe(VTHallo)
     412!$OMP END MASTER
     413!$OMP BARRIER
     414
     415!  write(*,*) 'vlspltgen_loc 494'
     416  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
     417
     418  DO iq=1,nqtot
     419    tr => tracers(iq)
     420!    write(*,*) 'vlspltgen 449: iq=',iq
     421    IF(tr%igen /= 1) CYCLE
     422#ifdef DEBUG_IO   
     423      CALL WriteField_u('zq',zq(:,:,iq))
     424      CALL WriteField_u('zm',zm(:,:,iq))
     425#endif
     426    !----------------------------------------------------------------------
     427    SELECT CASE(iadv(iq))
     428      CASE(0); CYCLE
     429      CASE(10); CALL   vly_loc(zq,pente_max,zm,mv,iq)
     430      CASE(14); CALL vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
     431      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     432    END SELECT
     433    !----------------------------------------------------------------------
     434  END DO
     435
     436  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
     437
     438  DO iq=1,nqtot
     439    tr => tracers(iq)
     440!    write(*,*) 'vlspltgen 477: iq=',iq
     441    IF(tr%igen /= 1) CYCLE
     442#ifdef DEBUG_IO   
     443    CALL WriteField_u('zq',zq(:,:,iq))
     444    CALL WriteField_u('zm',zm(:,:,iq))
     445#endif
     446    !----------------------------------------------------------------------
     447    SELECT CASE(iadv(iq))
     448      CASE(0); CYCLE
     449      CASE(10); CALL   vlx_loc(zq,pente_max,zm,mu,     ij_begin,ij_end,iq)
     450      CASE(14); CALL vlxqs_loc(zq,pente_max,zm,mu,qsat,ij_begin,ij_end,iq)
     451      CASE DEFAULT; STOP 'vlspltgen_p : schema non parallelise'
     452    END SELECT
     453    !----------------------------------------------------------------------
     454  END DO
     455
     456!  write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
     457  CALL check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
     458 
     459  ijb=ij_begin
     460  ije=ij_end
     461!  write(*,*) 'vlspltgen_loc 557'
     462!$OMP BARRIER     
     463
     464!  write(*,*) 'vlspltgen_loc 559' 
     465  DO iq=1,nqtot
     466  !  write(*,*) 'vlspltgen_loc 561, iq=',iq 
     467#ifdef DEBUG_IO   
     468    CALL WriteField_u('zq',zq(:,:,iq))
     469    CALL WriteField_u('zm',zm(:,:,iq))
     470#endif
     471!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
     472    DO l=1,llm
     473      DO ij=ijb,ije
     474!         print *,'zq-->',ij,l,iq,zq(ij,l,iq)
     475!         print *,'q-->',ij,l,iq,q(ij,l,iq)
     476        q(ij,l,iq)=zq(ij,l,iq)
     477      END DO
     478    END DO
     479!$OMP END DO NOWAIT   
     480  !  write(*,*) 'vlspltgen_loc 575'     
     481
     482!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     483    DO l=1,llm
     484      DO ij=ijb,ije-iip1+1,iip1
     485         q(ij+iim,l,iq)=q(ij,l,iq)
     486      END DO
     487    END DO
     488!$OMP END DO NOWAIT 
     489!  write(*,*) 'vlspltgen_loc 583' 
     490  END DO
    99491       
    100         ijb=ij_begin-iip1
    101         ije=ij_end+iip1
    102         if (pole_nord) ijb=ij_begin
    103         if (pole_sud) ije=ij_end
    104        
    105 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    106         DO l = 1, llm
    107          DO ij = ijb, ije
    108           tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
    109          ENDDO
    110          DO ij = ijb, ije
    111           zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
    112           play   = 0.5*(p(ij,l)+p(ij,l+1))
    113           qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
    114           qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
    115          ENDDO
    116         ENDDO
    117 c$OMP END DO NOWAIT
    118 c      PRINT*,'Debut vlsplt version debug sans vlyqs'
    119 
    120         zzpbar = 0.5 * pdt
    121         zzw    = pdt
    122 
    123       ijb=ij_begin
    124       ije=ij_end
    125       if (pole_nord) ijb=ijb+iip1
    126       if (pole_sud)  ije=ije-iip1
    127 
    128 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
    129       DO l=1,llm
    130         DO ij = ijb,ije
    131             mu(ij,l)=pbaru(ij,l) * zzpbar
    132          ENDDO
    133       ENDDO
    134 c$OMP END DO NOWAIT
    135      
    136       ijb=ij_begin-iip1
    137       ije=ij_end
    138       if (pole_nord) ijb=ij_begin
    139       if (pole_sud)  ije=ij_end-iip1
    140 
    141 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    142       DO l=1,llm
    143          DO ij=ijb,ije
    144             mv(ij,l)=pbarv(ij,l) * zzpbar
    145          ENDDO
    146       ENDDO
    147 c$OMP END DO NOWAIT
    148 
    149       ijb=ij_begin
    150       ije=ij_end
    151 
    152       DO iq=1,nqtot
    153 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
    154       DO l=1,llm
    155          DO ij=ijb,ije
    156             mw(ij,l,iq)=w(ij,l) * zzw
    157          ENDDO
    158       ENDDO
    159 c$OMP END DO NOWAIT
    160       ENDDO
    161 
    162       DO iq=1,nqtot 
    163 c$OMP MASTER
    164       DO ij=ijb,ije
    165          mw(ij,llm+1,iq)=0.
    166       ENDDO
    167 c$OMP END MASTER
    168       ENDDO
    169 
    170 c      CALL SCOPY(ijp1llm,q,1,zq,1)
    171 c      CALL SCOPY(ijp1llm,masse,1,zm,1)
    172 
    173        ijb=ij_begin
    174        ije=ij_end
    175 
    176       DO iq=1,nqtot       
    177 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    178         DO l=1,llm
    179           zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
    180           zm(ijb:ije,l,iq)=masse(ijb:ije,l)
    181         ENDDO
    182 c$OMP END DO NOWAIT
    183       ENDDO
    184 
    185 #ifdef DEBUG_IO     
    186        CALL WriteField_u('mu',mu)
    187        CALL WriteField_v('mv',mv)
    188        CALL WriteField_u('mw',mw)
    189        CALL WriteField_u('qsat',qsat)
    190 #endif
    191 
    192       ! verif temporaire
    193       ijb=ij_begin
    194       ije=ij_end 
    195       if (ok_iso_verif) then
    196         call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
    197       endif !if (ok_iso_verif) then   
    198 
    199 c$OMP BARRIER           
    200 !      DO iq=1,nqtot
    201       DO iq=1,nqperes ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
    202        !write(*,*) 'vlspltgen 192: iq,iadv=',iq,iadv(iq)
    203 #ifdef DEBUG_IO   
    204        CALL WriteField_u('zq',zq(:,:,iq))
    205        CALL WriteField_u('zm',zm(:,:,iq))
    206 #endif
    207         if(iadv(iq) == 0) then
    208        
    209           cycle
    210        
    211         else if (iadv(iq)==10) then
    212 
    213 #ifdef _ADV_HALO       
    214 ! CRisi: on ajoute les nombres de fils et tableaux des fils
    215 ! On suppose qu'on ne peut advecter les fils que par le schéma 10. 
    216           call vlx_loc(zq,pente_max,zm,mu,
    217      &                     ij_begin,ij_begin+2*iip1-1,iq)
    218           call vlx_loc(zq,pente_max,zm,mu,
    219      &               ij_end-2*iip1+1,ij_end,iq)
    220 #else
    221           call vlx_loc(zq,pente_max,zm,mu,
    222      &                     ij_begin,ij_end,iq)
    223 #endif
    224 
    225 c$OMP MASTER
    226           call VTb(VTHallo)
    227 c$OMP END MASTER
    228           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
    229           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
    230 ! CRisi
    231           do ifils=1,nqdesc(iq)
    232             iq2=iqfils(ifils,iq)
    233             call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
    234             call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
    235           enddo
    236 
    237 c$OMP MASTER
    238           call VTe(VTHallo)
    239 c$OMP END MASTER
    240         else if (iadv(iq)==14) then
    241 
    242 #ifdef _ADV_HALO           
    243           call vlxqs_loc(zq,pente_max,zm,mu,
    244      &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
    245           call vlxqs_loc(zq,pente_max,zm,mu,
    246      &                   qsat,ij_end-2*iip1+1,ij_end,iq)
    247 #else
    248           call vlxqs_loc(zq,pente_max,zm,mu,
    249      &                   qsat,ij_begin,ij_end,iq)
    250 #endif
    251 
    252 c$OMP MASTER
    253           call VTb(VTHallo)
    254 c$OMP END MASTER
    255 
    256           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
    257           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
    258           do ifils=1,nqdesc(iq)
    259             iq2=iqfils(ifils,iq)
    260             call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
    261             call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
    262           enddo
    263 
    264 c$OMP MASTER
    265           call VTe(VTHallo)
    266 c$OMP END MASTER
    267         else
    268        
    269           stop 'vlspltgen_p : schema non parallelise'
    270      
    271         endif
    272      
    273       enddo !DO iq=1,nqperes
    274      
    275      
    276 c$OMP BARRIER     
    277 c$OMP MASTER     
    278       call VTb(VTHallo)
    279 c$OMP END MASTER
    280 
    281       call SendRequest(MyRequest1)
    282 
    283 c$OMP MASTER
    284       call VTe(VTHallo)
    285 c$OMP END MASTER       
    286 c$OMP BARRIER
    287 
    288       ! verif temporaire
    289       ijb=ij_begin-2*iip1
    290       ije=ij_end+2*iip1 
    291       if (pole_nord) ijb=ij_begin
    292       if (pole_sud)  ije=ij_end 
    293       if (ok_iso_verif) then
    294            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
    295       endif !if (ok_iso_verif) then
    296 
    297       do iq=1,nqperes
    298         !write(*,*) 'vlspltgen 279: iq=',iq
    299 
    300         if(iadv(iq) == 0) then
    301        
    302           cycle
    303        
    304         else if (iadv(iq)==10) then
    305 
    306 #ifdef _ADV_HALLO
    307           call vlx_loc(zq,pente_max,zm,mu,
    308      &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
    309 #endif       
    310         else if (iadv(iq)==14) then
    311 #ifdef _ADV_HALLO
    312           call vlxqs_loc(zq,pente_max,zm,mu,
    313      &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
    314 #endif   
    315         else
    316        
    317           stop 'vlspltgen_p : schema non parallelise'
    318      
    319         endif
    320      
    321       enddo
    322 c$OMP BARRIER     
    323 c$OMP MASTER
    324       call VTb(VTHallo)
    325 c$OMP END MASTER
    326 
    327 !      call WaitRecvRequest(MyRequest1)
    328 !      call WaitSendRequest(MyRequest1)
    329 c$OMP BARRIER
    330        call WaitRequest(MyRequest1)
    331 
    332 
    333 c$OMP MASTER
    334       call VTe(VTHallo)
    335 c$OMP END MASTER
    336 c$OMP BARRIER
    337 
    338      
    339       if (ok_iso_verif) then
    340            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
    341       endif !if (ok_iso_verif) then       
    342       if (ok_iso_verif) then
    343            ijb=ij_begin-2*iip1
    344            ije=ij_end+2*iip1
    345            if (pole_nord) ijb=ij_begin
    346            if (pole_sud)  ije=ij_end
    347            call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
    348       endif !if (ok_iso_verif) then 
    349 
    350       do iq=1,nqperes
    351        !write(*,*) 'vlspltgen 321: iq=',iq
    352 #ifdef DEBUG_IO   
    353        CALL WriteField_u('zq',zq(:,:,iq))
    354        CALL WriteField_u('zm',zm(:,:,iq))
    355 #endif
    356 
    357         if(iadv(iq) == 0) then
    358        
    359           cycle
    360        
    361         else if (iadv(iq)==10) then
    362        
    363           call vly_loc(zq,pente_max,zm,mv,iq)
    364  
    365         else if (iadv(iq)==14) then
    366      
    367           call vlyqs_loc(zq,pente_max,zm,mv,
    368      &                   qsat,iq)
    369  
    370         else
    371        
    372           stop 'vlspltgen_p : schema non parallelise'
    373      
    374         endif
    375        
    376        enddo
    377 
    378       if (ok_iso_verif) then
    379            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
    380       endif !if (ok_iso_verif) then
    381 
    382       do iq=1,nqperes
    383       !write(*,*) 'vlspltgen 349: iq=',iq
    384 #ifdef DEBUG_IO   
    385        CALL WriteField_u('zq',zq(:,:,iq))
    386        CALL WriteField_u('zm',zm(:,:,iq))
    387 #endif
    388         if(iadv(iq) == 0) then
    389          
    390           cycle
    391        
    392         else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
    393 
    394 c$OMP BARRIER       
    395 #ifdef _ADV_HALLO
    396           call vlz_loc(zq,pente_max,zm,mw,
    397      &               ij_begin,ij_begin+2*iip1-1,iq)
    398           call vlz_loc(zq,pente_max,zm,mw,
    399      &               ij_end-2*iip1+1,ij_end,iq)
    400 #else
    401           call vlz_loc(zq,pente_max,zm,mw,
    402      &               ij_begin,ij_end,iq)
    403 #endif
    404 c$OMP BARRIER
    405 
    406 c$OMP MASTER
    407           call VTb(VTHallo)
    408 c$OMP END MASTER
    409 
    410           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
    411           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
    412           ! CRisi
    413           do ifils=1,nqdesc(iq)
    414             iq2=iqfils(ifils,iq)
    415             call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
    416             call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
    417           enddo     
    418 c$OMP MASTER
    419           call VTe(VTHallo)
    420 c$OMP END MASTER       
    421 c$OMP BARRIER
    422         else
    423        
    424           stop 'vlspltgen_p : schema non parallelise'
    425      
    426         endif
    427      
    428       enddo
    429 c$OMP BARRIER     
    430 
    431 c$OMP MASTER       
    432       call VTb(VTHallo)
    433 c$OMP END MASTER
    434 
    435       call SendRequest(MyRequest2)
    436 
    437 c$OMP MASTER
    438       call VTe(VTHallo)
    439 c$OMP END MASTER       
    440 
    441 
    442       if (ok_iso_verif) then
    443            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
    444       endif !if (ok_iso_verif) then
    445 
    446 c$OMP BARRIER
    447       do iq=1,nqperes
    448       !write(*,*) 'vlspltgen 409: iq=',iq
    449 
    450         if(iadv(iq) == 0) then
    451          
    452           cycle
    453        
    454         else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
    455 c$OMP BARRIER       
    456 
    457 #ifdef _ADV_HALLO
    458           call vlz_loc(zq,pente_max,zm,mw,
    459      &               ij_begin+2*iip1,ij_end-2*iip1,iq)
    460 #endif
    461 
    462 c$OMP BARRIER       
    463         else
    464        
    465           stop 'vlspltgen_p : schema non parallelise'
    466      
    467         endif
    468      
    469       enddo
    470       !write(*,*) 'vlspltgen_loc 476'
    471 
    472 c$OMP BARRIER
    473       !write(*,*) 'vlspltgen_loc 477'
    474 c$OMP MASTER
    475       call VTb(VTHallo)
    476 c$OMP END MASTER
    477 
    478 !      call WaitRecvRequest(MyRequest2)
     492  CALL check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
     493
     494!$OMP BARRIER
     495
     496!!$OMP MASTER     
     497!      call WaitSendRequest(MyRequest1)
    479498!      call WaitSendRequest(MyRequest2)
    480 c$OMP BARRIER
    481        CALL WaitRequest(MyRequest2)
    482 
    483 c$OMP MASTER
    484       call VTe(VTHallo)
    485 c$OMP END MASTER
    486 c$OMP BARRIER
    487 
    488 
    489       !write(*,*) 'vlspltgen_loc 494'
    490       if (ok_iso_verif) then
    491            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
    492       endif !if (ok_iso_verif) then
    493 
    494       do iq=1,nqperes
    495       !write(*,*) 'vlspltgen 449: iq=',iq
    496 #ifdef DEBUG_IO   
    497        CALL WriteField_u('zq',zq(:,:,iq))
    498        CALL WriteField_u('zm',zm(:,:,iq))
    499 #endif
    500         if(iadv(iq) == 0) then
    501        
    502           cycle
    503        
    504         else if (iadv(iq)==10) then
    505        
    506           call vly_loc(zq,pente_max,zm,mv,iq)
    507  
    508         else if (iadv(iq)==14) then
    509      
    510           call vlyqs_loc(zq,pente_max,zm,mv,
    511      &                   qsat,iq)
    512  
    513         else
    514        
    515           stop 'vlspltgen_p : schema non parallelise'
    516      
    517         endif
    518        
    519        enddo !do iq=1,nqperes
    520 
    521       if (ok_iso_verif) then
    522            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
    523       endif !if (ok_iso_verif) then
    524 
    525       do iq=1,nqperes
    526       !write(*,*) 'vlspltgen 477: iq=',iq
    527 #ifdef DEBUG_IO   
    528        CALL WriteField_u('zq',zq(:,:,iq))
    529        CALL WriteField_u('zm',zm(:,:,iq))
    530 #endif
    531         if(iadv(iq) == 0) then
    532          
    533           cycle
    534        
    535         else if (iadv(iq)==10) then
    536        
    537           call vlx_loc(zq,pente_max,zm,mu,
    538      &               ij_begin,ij_end,iq)
    539  
    540         else if (iadv(iq)==14) then
    541      
    542           call vlxqs_loc(zq,pente_max,zm,mu,
    543      &                 qsat, ij_begin,ij_end,iq)
    544  
    545         else
    546        
    547           stop 'vlspltgen_p : schema non parallelise'
    548      
    549         endif
    550        
    551        enddo !do iq=1,nqperes
    552 
    553       !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
    554       if (ok_iso_verif) then
    555            call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
    556       endif !if (ok_iso_verif) then
    557      
    558       ijb=ij_begin
    559       ije=ij_end
    560       !write(*,*) 'vlspltgen_loc 557'
    561 c$OMP BARRIER     
    562 
    563       !write(*,*) 'vlspltgen_loc 559' 
    564       DO iq=1,nqtot
    565        !write(*,*) 'vlspltgen_loc 561, iq=',iq 
    566 #ifdef DEBUG_IO   
    567        CALL WriteField_u('zq',zq(:,:,iq))
    568        CALL WriteField_u('zm',zm(:,:,iq))
    569 #endif
    570 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
    571         DO l=1,llm
    572            DO ij=ijb,ije
    573 c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
    574 c             print *,'q-->',ij,l,iq,q(ij,l,iq)
    575              q(ij,l,iq)=zq(ij,l,iq)
    576            ENDDO
    577         ENDDO
    578 c$OMP END DO NOWAIT   
    579       !write(*,*) 'vlspltgen_loc 575'     
    580 
    581 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    582         DO l=1,llm
    583            DO ij=ijb,ije-iip1+1,iip1
    584               q(ij+iim,l,iq)=q(ij,l,iq)
    585            ENDDO
    586         ENDDO
    587 c$OMP END DO NOWAIT 
    588       !write(*,*) 'vlspltgen_loc 583' 
    589       ENDDO !DO iq=1,nqtot
    590        
    591       if (ok_iso_verif) then
    592            call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
    593       endif !if (ok_iso_verif) then
    594 
    595 c$OMP BARRIER
    596 
    597 cc$OMP MASTER     
    598 c      call WaitSendRequest(MyRequest1)
    599 c      call WaitSendRequest(MyRequest2)
    600 cc$OMP END MASTER
    601 cc$OMP BARRIER
    602 
    603       !write(*,*) 'vlspltgen 597: sortie' 
    604       RETURN
    605       END
     499!!$OMP END MASTER
     500!!$OMP BARRIER
     501
     502!  write(*,*) 'vlspltgen 597: sortie' 
     503
     504END

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/vlspltqs_loc.F

    r3851 r3852  
    1212c   --------------------------------------------------------------------
    1313      USE parallel_lmdz
    14       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils, ! CRisi                 &
     14      USE infotrac, ONLY : nqtot, tracers, tra,        ! CRisi                 &
    1515     &                     qperemin,masseqmin,ratiomin ! MVals et CRisi
    1616      IMPLICIT NONE
    … …  
    4040      REAL u_mq(ijb_u:ije_u,llm)
    4141      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    42       INTEGER ifils,iq2 ! CRisi
    43 
     42      INTEGER ichld,iq2 ! CRisi
     43      TYPE(tra), POINTER :: tr
    4444
    4545      REAL      SSUM
    … …  
    4747
    4848      INTEGER ijb,ije,ijb_x,ije_x
    49      
     49
     50      tr => tracers(iq)
     51
    5052      !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
    5153!     &   iq,ijb_x
    … …  
    337339! CRisi: appel récursif de l'advection sur les fils.
    338340! Il faut faire ça avant d'avoir mis à jour q et masse
    339       !write(*,*) 'vlspltqs 336: iq,ijb_x,nqfils(iq)=',
    340 !     &     iq,ijb_x,nqfils(iq) 
    341 
    342       if (nqfils(iq).gt.0) then 
    343        do ifils=1,nqdesc(iq)
    344          iq2=iqfils(ifils,iq)
     341      !write(*,*) 'vlspltqs 336: iq,ijb_x,tr%nchld=',
     342!     &     iq,ijb_x,tr%nchld 
     343
     344      if(tr%ndesc > 0) then 
     345       do ichld=1,tr%ndesc
     346         iq2=tr%idesc(ichld)
    345347c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    346348         DO l=1,llm
    … …  
    356358         enddo
    357359c$OMP END DO NOWAIT
    358         enddo !do ifils=1,nqfils(iq)
    359         do ifils=1,nqfils(iq)
    360          iq2=iqfils(ifils,iq)
     360        enddo !do ichld=1,tr%nchld
     361        do ichld=1,tr%nchld
     362         iq2=tr%idesc(ichld)
    361363         !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
    362364         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
    363         enddo !do ifils=1,nqfils(iq)
    364       endif !if (nqfils(iq).gt.0) then
     365        enddo !do ichld=1,tr%nchld
     366      endif !if(tr%ndesc > 0)
    365367! end CRisi
    366368
    … …  
    389391
    390392! retablir les fils en rapport de melange par rapport a l'air:
    391       if (nqfils(iq).gt.0) then 
    392        do ifils=1,nqdesc(iq)
    393          iq2=iqfils(ifils,iq) 
     393      if(tr%ndesc > 0) then 
     394       do ichld=1,tr%ndesc
     395         iq2=tr%idesc(ichld) 
    394396c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    395397         DO l=1,llm
    … …  
    402404         enddo
    403405c$OMP END DO NOWAIT
    404         enddo !do ifils=1,nqdesc(iq)
    405       endif !if (nqfils(iq).gt.0) then
     406        enddo !do ichld=1,tr%ndesc
     407      endif !if(tr%ndesc > 0)
    406408
    407409      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
    … …  
    426428c   --------------------------------------------------------------------
    427429      USE parallel_lmdz
    428       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils, ! CRisi                 &
     430      USE infotrac, ONLY : nqtot, tracers, tra,        ! CRisi                 &
    429431     &                     qperemin,masseqmin,ratiomin ! MVals et CRisi
    430432      USE comconst_mod, ONLY: pi
    … …  
    470472c
    471473      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    472       INTEGER ifils,iq2 ! CRisi
     474      INTEGER ichld,iq2 ! CRisi
     475      TYPE(tra), POINTER :: tr
    473476
    474477      REAL      SSUM
    … …  
    733736! CRisi: appel récursif de l'advection sur les fils.
    734737! Il faut faire ça avant d'avoir mis à jour q et masse
    735       !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
     738      !write(*,*) 'vlyqs 689: iq,tr%nchld=',iq,tr%nchld
    736739     
    737740      ijb=ij_begin-2*iip1
    … …  
    747750      !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
    748751      !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
    749       if (nqfils(iq).gt.0) then 
    750        do ifils=1,nqdesc(iq)
    751          iq2=iqfils(ifils,iq)
     752      if(tr%ndesc > 0) then 
     753       do ichld=1,tr%ndesc
     754         iq2=tr%idesc(ichld)
    752755c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    753756         DO l=1,llm
    … …  
    771774         enddo !DO l=1,llm
    772775c$OMP END DO NOWAIT
    773         enddo !do ifils=1,nqdesc(iq)
    774         do ifils=1,nqfils(iq)
    775          iq2=iqfils(ifils,iq)
     776        enddo !do ichld=1,tr%ndesc
     777        do ichld=1,tr%nchld
     778         iq2=tr%idesc(ichld)
    776779         !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
    777780         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
    778         enddo !do ifils=1,nqfils(iq)
    779       endif !if (nqfils(iq).gt.0) then
     781        enddo !do ichld=1,tr%nchld
     782      endif !if(tr%ndesc > 0)
    780783
    781784       
    … …  
    856859!      if (pole_sud)  ije=ij_end-iip1
    857860 
    858       if (nqfils(iq).gt.0) then 
    859        do ifils=1,nqdesc(iq)
    860          iq2=iqfils(ifils,iq) 
     861      if(tr%ndesc > 0) then 
     862       do ichld=1,tr%ndesc
     863         iq2=tr%idesc(ichld) 
    861864c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    862865         DO l=1,llm
    … …  
    866869         enddo
    867870c$OMP END DO NOWAIT
    868         enddo !do ifils=1,nqdesc(iq)
    869       endif !if (nqfils(iq).gt.0) then
     871        enddo !do ichld=1,tr%ndesc
     872      endif !if(tr%ndesc > 0)
    870873
    871874

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/vlz_mod.F90

    r2281 r3852  
    1515  USE allocate_field_mod
    1616  USE parallel_lmdz
    17   USE infotrac
     17  USE infotrac, ONLY: nqtot, tracers
    1818  USE dimensions_mod
    1919  IMPLICIT NONE
    … …  
    2525    CALL allocate_u(dzqw,llm,d)
    2626    CALL allocate_u(adzqw,llm,d)
    27     if (nqdesc_tot.gt.0) then
    28     !CALL allocate_u(masseq,llm,nqtot,d)
    29     CALL allocate_u(Ratio,llm,nqtot,d)
    30     endif !if (nqdesc_tot.gt.0) then
     27    IF(ANY(tracers(:)%ndesc > 0) THEN
     28      !CALL allocate_u(masseq,llm,nqtot,d)
     29      CALL allocate_u(Ratio,llm,nqtot,d)
     30    END IF
    3131
    3232  END SUBROUTINE vlz_allocate

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/writedynav_loc.F

    r2622 r3852  
    1111      USE parallel_lmdz
    1212      USE misc_mod
    13       USE infotrac, ONLY : nqtot, ttext
     13      USE infotrac, ONLY : nqtot
    1414      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
    1515      USE comconst_mod, ONLY: cpp
    … …  
    177177!!$OMP MASTER     
    178178!        DO iq=1,nqtot
    179 !          call histwrite(histaveid, ttext(iq), itau_w, q(ijb:ije,:,iq),
     179!          call histwrite(histaveid, tracers(iq)%lnam, itau_w, q(ijb:ije,:,iq),
    180180!     .                   iip1*jjn*llm, ndexu)
    181181!        enddo

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/writehist_loc.F

    r2622 r3852  
    1111      USE parallel_lmdz
    1212      USE misc_mod
    13       USE infotrac, ONLY : nqtot, ttext
     13      USE infotrac, ONLY : nqtot
    1414      use com_io_dyn_mod, only : histid,histvid,histuid
    1515      USE comconst_mod, ONLY: cpp
    … …  
    177177!!$OMP MASTER     
    178178!        DO iq=1,nqtot
    179 !          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq),
     179!          call histwrite(histid, tracers(iq)%lnam, itau_w, q(ijb:ije,:,iq),
    180180!     .                   iip1*jjn*llm, ndexu)
    181181!        enddo
Note: See TracChangeset for help on using the changeset viewer.