Changeset 3852


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
Files:
3 added
42 edited
4 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/advtrac.F90

    r2622 r3852  
    99  !            M.A Filiberti (04/2002)
    1010  !
    11   USE infotrac, ONLY: nqtot, iadv,nqperes,ok_iso_verif
     11  USE infotrac, ONLY: nqtot, tracers
    1212  USE control_mod, ONLY: iapp_tracvl, day_step
    1313  USE comconst_mod, ONLY: dtvr
    … …  
    4848  INTEGER iadvtr
    4949  INTEGER ij,l,iq,iiq
     50  INTEGER, POINTER :: iadv(:)
    5051  REAL zdpmin, zdpmax
    5152  EXTERNAL  minmax
    … …  
    7374  real, save :: cflxmax(llm),cflymax(llm),cflzmax(llm)
    7475
     76  iadv => tracers(:)%iadv
     77
    7578  IF(iadvtr.EQ.0) THEN
    7679     pbaruc(:,:)=0
    … …  
    219222     !-----------------------------------------------------------
    220223
    221      if (ok_iso_verif) then
    222            write(*,*) 'advtrac 227'
    223            call check_isotopes_seq(q,ip1jmp1,'advtrac 162')
    224      endif !if (ok_iso_verif) then
    225 
    226      do iq=1,nqperes
     224     call check_isotopes_seq(q,ip1jmp1,'advtrac 162')
     225
     226     do iq=1,nqtot
    227227        !        call clock(t_initial)
    228         if(iadv(iq) == 0) cycle
     228        if(iadv(iq) == 0 .OR. tracers(iq)%igen /= 1) cycle
    229229        !   ----------------------------------------------------------------
    230230        !   Schema de Van Leer I MUSCL
    … …  
    394394     end DO
    395395
    396      if (ok_iso_verif) then
    397            write(*,*) 'advtrac 402'
    398            call check_isotopes_seq(q,ip1jmp1,'advtrac 397')
    399      endif !if (ok_iso_verif) then
     396     call check_isotopes_seq(q,ip1jmp1,'advtrac 397')
    400397
    401398     !------------------------------------------------------------------

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/check_isotopes.F90

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

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/dynetat0.f90

    r2859 r3852  
    66! Purpose: Initial state reading.
    77!-------------------------------------------------------------------------------
    8   USE infotrac
     8  USE infotrac,    ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
    99  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQ_VARID, NF90_NoErr, &
    1010                         NF90_CLOSE, NF90_GET_VAR
     11  USE strings_mod, ONLY: strIdx
    1112  USE control_mod, ONLY: planet_type
    1213  USE assert_eq_m, ONLY: assert_eq
    … …  
    3637!===============================================================================
    3738! Local variables:
    38   CHARACTER(LEN=256) :: msg, var, modname
     39  CHARACTER(LEN=256) :: sdum, var, modname, oldH2O(3), newH2O(3)
    3940  INTEGER, PARAMETER :: length=100
    40   INTEGER :: iq, fID, vID, idecal!, iml, jml, lml, nqt
     41  INTEGER :: iq, fID, vID, idecal, ix!, iml, jml, lml, nqt
    4142  REAL    :: time, tab_cntrl(length)               !--- RUN PARAMS TABLE
     43 TYPE(tra), POINTER :: tr
    4244!-------------------------------------------------------------------------------
    4345  modname="dynetat0"
     46  oldH2O=['H2Ov ','H2Ol ','H2Oi ']
     47  newH2O=['H2O-g','H2O-l','H2O-s']
    4448
    4549!--- Initial state file opening
    … …  
    126130!--- Tracers
    127131  DO iq=1,nqtot
    128     var=tname(iq)
     132    tr => tracers(iq)
     133    var = tr%name
    129134    IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN
    130135      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var); CYCLE
     136#ifdef INCA
     137    ELSE IF(var == "O3") THEN          !--- INCA and O3 missing: take OX instead
     138      WRITE(lunout,*) 'Tracer O3 is missing - it is initialized to OX'
     139        IF(NF90_INQ_VARID(fID,"OX",vID) == NF90_NoErr) THEN
     140           CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var); CYCLE
     141        END IF
     142#endif
     143    ELSE                               !--- Old file, water: H2Ov/l/i instead of H2O-g/-l/-s
     144      ix = strIdx(newH2O, var)         !--- Current tracer is water (new name) ?
     145      IF(ix /= 0) THEN                 !--- Then read the field, using the old name.
     146        IF(NF90_INQ_VARID(fID,oldH2O(ix),vID) == NF90_NoErr) THEN
     147           CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var); CYCLE
     148        END IF
     149      END IF
    131150    END IF
    132151    WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"
    133152    WRITE(lunout,*)"         It is hence initialized to zero"
    134153    q(:,:,:,iq)=0.
    135    !--- CRisi: for isotops, theoretical initialization using very simplified
    136    !           Rayleigh distillation las.
    137     IF(ok_isotopes.AND.iso_num(iq)>0) THEN
    138       IF(zone_num(iq)==0) q(:,:,:,iq)=q(:,:,:,iqpere(iq))*tnat(iso_num(iq))    &
    139      &             *(q(:,:,:,iqpere(iq))/30.e-3)**(alpha_ideal(iso_num(iq))-1)
    140       IF(zone_num(iq)==1) q(:,:,:,iq)=q(:,:,:,iqiso(iso_indnum(iq),phase_num(iq)))
     154    !--- CRisi: for isotops, theoretical initialization using very simplified
     155    !           Rayleigh distillation las.
     156    IF(niso > 0 .AND. tr%iso_num > 0) THEN
     157      IF(tr%iso_zon == 0) q(:,:,:,iq) = q(:,:,:,tr%iprnt)         *        tnat(tr%iso_num)  &
     158                                      *(q(:,:,:,tr%iprnt)/30.e-3)**(alpha_ideal(tr%iso_num)-1)
     159      IF(tr%iso_zon == 1) q(:,:,:,iq) = q(:,:,:,iTraPha(tr%iso_num,tr%iso_pha))
    141160    END IF
    142161  END DO
    … …  
    153172  INTEGER,          INTENT(IN) :: n1, n2
    154173  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
    155   CHARACTER(LEN=100) :: s1, s2
     174  CHARACTER(LEN=256) :: s1, s2
    156175  IF(n1/=n2) THEN
    157176    s1='value of '//TRIM(str1)//' ='
    158177    s2=' read in starting file differs from parametrized '//TRIM(str2)//' ='
    159     WRITE(msg,'(10x,a,i4,2x,a,i4)'),TRIM(ADJUSTL(s1)),n1,TRIM(ADJUSTL(s2)),n2
    160     CALL ABORT_gcm(TRIM(modname),TRIM(msg),1)
     178    WRITE(sdum,'(10x,a,i4,2x,a,i4)'),TRIM(ADJUSTL(s1)),n1,TRIM(ADJUSTL(s2)),n2
     179    CALL ABORT_gcm(TRIM(modname),TRIM(sdum),1)
    161180  END IF
    162181END SUBROUTINE check_dim
    … …  
    193212  IF(ierr==NF90_NoERR) RETURN
    194213  SELECT CASE(typ)
    195     CASE('inq');   msg="Field <"//TRIM(nam)//"> is missing"
    196     CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
    197     CASE('open');  msg="File opening failed for <"//TRIM(nam)//">"
    198     CASE('close'); msg="File closing failed for <"//TRIM(nam)//">"
     214    CASE('inq');   sdum="Field <"//TRIM(nam)//"> is missing"
     215    CASE('get');   sdum="Reading failed for <"//TRIM(nam)//">"
     216    CASE('open');  sdum="File opening failed for <"//TRIM(nam)//">"
     217    CASE('close'); sdum="File closing failed for <"//TRIM(nam)//">"
    199218  END SELECT
    200   CALL ABORT_gcm(TRIM(modname),TRIM(msg),ierr)
     219  CALL ABORT_gcm(TRIM(modname),TRIM(sdum),ierr)
    201220END SUBROUTINE err
    202221

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/dynredem.F90

    r3851 r3852  
    77  USE IOIPSL
    88#endif
    9   USE infotrac
     9  USE infotrac, ONLY: nqtot, tracers
    1010  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
    1111                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
    … …  
    145145  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
    146146  DO iq=1,nqtot
    147     CALL cre_var(nid,tname(iq),ttext(iq),[rlonvID,rlatuID,sID,timID])
     147    CALL cre_var(nid,tracers(iq)%name,tracers(iq)%lnam,[rlonvID,rlatuID,sID,timID])
    148148  END DO
    149149  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
    … …  
    166166! Purpose: Write the NetCDF restart file (append).
    167167!-------------------------------------------------------------------------------
    168   USE infotrac
     168  USE infotrac, ONLY: nqtot, tracers, type_trac
    169169  USE control_mod
    170170  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
    … …  
    226226
    227227!--- Tracers in file "start_trac.nc" (added by Anne)
    228   lread_inca=.FALSE.; fil="start_trac.nc"
    229   IF(type_trac=='inca') INQUIRE(FILE=fil,EXIST=lread_inca)
     228  fil="start_trac.nc"
     229  INQUIRE(FILE=fil, EXIST=lread_inca)
     230  lread_inca = lread_inca .AND. type_trac == 'inca'
    230231  IF(lread_inca) CALL err(NF90_OPEN(fil,NF90_NOWRITE,nid_trac),"open")
    231232
    232233!--- Save tracers
    233   DO iq=1,nqtot; var=tname(iq); ierr=-1
     234  DO iq=1,nqtot; var=tracers(iq)%name; ierr=-1
    234235    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
    235236      fil="start_trac.nc"
    … …  
    237238      dum='inq'; IF(ierr==NF90_NoErr) dum='fnd'
    238239      WRITE(lunout,*)msg(dum,var)
    239 
    240 
    241240      IF(ierr==NF90_NoErr) CALL dynredem_read_u(nid_trac,var,q(:,:,:,iq),llm)
    242241    END IF

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/iniacademic.F90

    r2622 r3852  
    55
    66  USE filtreg_mod, ONLY: inifilr
    7   USE infotrac
     7  USE infotrac, ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
    88  USE control_mod, ONLY: day_step,planet_type
    99#ifdef CPP_IOIPSL
    … …  
    7373
    7474  REAL zdtvr
    75  
     75
     76  TYPE(tra), POINTER :: tr
     77 
    7678  character(len=*),parameter :: modname="iniacademic"
    7779  character(len=80) :: abort_message
    … …  
    9698  time_0=0.
    9799  day_ref=1
    98   annee_ref=0
     100!  annee_ref=0
    99101
    100102  im         = iim
    … …  
    265267              ! CRisi: init des isotopes
    266268              ! distill de Rayleigh très simplifiée
    267               if (ok_isotopes) then
    268                 if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then         
    269                    q(:,:,i)=q(:,:,iqpere(i))             &
    270       &                  *tnat(iso_num(i))               &
    271       &                  *(q(:,:,iqpere(i))/30.e-3)      &
    272       &                  **(alpha_ideal(iso_num(i))-1)
    273                 endif               
    274                 if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
    275                   q(:,:,i)=q(:,:,iqiso(iso_indnum(i),phase_num(i)))
    276                 endif
    277               endif !if (ok_isotopes) then
     269              tr => tracers(i)
     270              if (niso > 0 .AND. tr%iso_num > 0) then
     271                 if(tr%iso_zon == 0) q(:,:,i) =         &
     272      &            q(:,:,tr%iprnt)*tnat(tr%iso_num)     &
     273      &          *(q(:,:,tr%iprnt)/30.e-3)              &
     274      &           **(alpha_ideal(tr%iso_num)-1)
     275                 if (tr%iso_zon == 1) q(:,:,i) =        &
     276                   q(:,:,iTraPha(tr%iso_num,tr%iso_pha))
     277              endif !if (niso > 0 .AND. tr%iso_num > 0)
    278278
    279279           enddo
    … …  
    282282        endif ! of if (planet_type=="earth")
    283283
    284         if (ok_iso_verif) then
    285            call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
    286         endif !if (ok_iso_verif) then
     284        call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
    287285
    288286        ! add random perturbation to temperature

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/integrd.F

    r2603 r3852  
    212212        ENDDO
    213213
     214        CALL check_isotopes_seq(q,ip1jmp1,'integrd 342')
     215
    214216        CALL qminimum( q, nq, deltap )
     217
     218        CALL check_isotopes_seq(q,ip1jmp1,'integrd 346')
    215219
    216220c
    … …  
    235239        ENDDO
    236240       ENDDO
     241       CALL check_isotopes_seq(q,ip1jmp1,'integrd 409')
    237242
    238243! Ehouarn: forget about finvmaold

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/leapfrog.F

    r3416 r3852  
    1111      use IOIPSL
    1212#endif
    13       USE infotrac, ONLY: nqtot,ok_iso_verif
     13      USE infotrac, ONLY: nqtot
    1414      USE guide_mod, ONLY : guide_main
    1515      USE write_field, ONLY: writefield
    … …  
    237237      jH_cur = jH_cur - int(jH_cur)
    238238
    239         if (ok_iso_verif) then
    240            call check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
    241         endif !if (ok_iso_verif) then
     239      call check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
    242240
    243241#ifdef CPP_IOIPSL
    … …  
    271269!      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
    272270
    273         if (ok_iso_verif) then
    274            call check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
    275         endif !if (ok_iso_verif) then
     271      call check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
    276272
    277273   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    … …  
    323319      endif
    324320
    325 
    326         if (ok_iso_verif) then
    327            call check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
    328         endif !if (ok_iso_verif) then
     321      call check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
    329322
    330323c-----------------------------------------------------------------------
    … …  
    345338c   -------------------------------------------------------------
    346339
    347         if (ok_iso_verif) then
    348            call check_isotopes_seq(q,ip1jmp1,
     340      call check_isotopes_seq(q,ip1jmp1,
    349341     &           'leapfrog 686: avant caladvtrac')
    350         endif !if (ok_iso_verif) then
    351342
    352343      IF( forward. OR . leapf )  THEN
    … …  
    376367c   ----------------------------------
    377368
    378         if (ok_iso_verif) then
    379            write(*,*) 'leapfrog 720'
    380            call check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
    381         endif !if (ok_iso_verif) then
     369       call check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
    382370       
    383371       CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    … …  
    385373!     $              finvmaold                                    )
    386374
    387        if (ok_iso_verif) then
    388           write(*,*) 'leapfrog 724'
    389            call check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
    390         endif !if (ok_iso_verif) then
     375       call check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
    391376
    392377c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
    … …  
    552537        CALL massdair(p,masse)
    553538
    554         if (ok_iso_verif) then
    555            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
    556         endif !if (ok_iso_verif) then
     539        call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
    557540
    558541c-----------------------------------------------------------------------
    … …  
    639622c   preparation du pas d'integration suivant  ......
    640623
    641         if (ok_iso_verif) then
    642            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
    643         endif !if (ok_iso_verif) then
     624      call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
    644625
    645626      IF ( .NOT.purmats ) THEN
    … …  
    703684            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    704685
    705         if (ok_iso_verif) then
    706            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
    707         endif !if (ok_iso_verif) then
     686            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
    708687
    709688c-----------------------------------------------------------------------
    … …  
    785764      ELSE ! of IF (.not.purmats)
    786765
    787         if (ok_iso_verif) then
    788            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
    789         endif !if (ok_iso_verif) then
     766        call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
    790767
    791768c       ........................................................
    … …  
    812789            ELSE ! of IF(forward) i.e. backward step
    813790 
    814         if (ok_iso_verif) then
    815            call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
    816         endif !if (ok_iso_verif) then 
     791              call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
    817792
    818793              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/qminimum.F

    r2600 r3852  
    44      SUBROUTINE qminimum( q,nqtot,deltap )
    55
    6       USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
     6      USE infotrac, ONLY: niso, nitr, iTraPha
    77      IMPLICIT none
    88c
    … …  
    4949c
    5050
    51         if (ok_iso_verif) then
    52            call check_isotopes_seq(q,ip1jmp1,'qminimum 52')   
    53         endif !if (ok_iso_verif) then     
     51      call check_isotopes_seq(q,ip1jmp1,'qminimum 52')   
    5452
    5553      zx_defau_diag(:,:,:)=0.0
    … …  
    5957          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
    6058
    61               if (ok_isotopes) then
    62                  zx_defau_diag(i,k,iq_liq)=AMAX1
     59              if (niso > 0) zx_defau_diag(i,k,iq_liq)=AMAX1
    6360     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
    64               endif !if (ok_isotopes) then
    6561
    6662             q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
    … …  
    8076          if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
    8177
    82             if (ok_isotopes) then
    83               zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
    84             endif !if (ok_isotopes) then
     78            zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
    8579
    8680            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
    … …  
    110104
    111105      !write(*,*) 'qminimum 128'
    112       if (ok_isotopes) then
     106      if (niso > 0) then
    113107      ! CRisi: traiter de même les traceurs d'eau
    114108      ! Mais il faut les prendre à l'envers pour essayer de conserver la
    … …  
    130124          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
    131125              ! on ajoute la vapeur en k             
    132               do ixt=1,ntraciso
    133                q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     126              do ixt=1,nitr
     127               q(i,k,iTraPha(ixt,iq_vap))=q(i,k,iTraPha(ixt,iq_vap))
    134128     :              +zx_defau_diag(i,k,iq_vap)
    135      :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     129     :              *q(i,k-1,iTraPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
    136130               
    137131              ! et on la retranche en k-1
    138                q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
     132               q(i,k-1,iTraPha(ixt,iq_vap))=q(i,k-1,iTraPha(ixt,iq_vap))
    139133     :              -zx_defau_diag(i,k,iq_vap)
    140134     :              *deltap(i,k)/deltap(i,k-1)
    141      :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     135     :              *q(i,k-1,iTraPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
    142136
    143               enddo !do ixt=1,niso
     137              enddo !do ixt=1,nitr
    144138              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
    145139     :               +zx_defau_diag(i,k,iq_vap)
    … …  
    151145       enddo !do k=2,llm
    152146
    153         if (ok_iso_verif) then     
    154            call check_isotopes_seq(q,ip1jmp1,'qminimum 168')
    155         endif !if (ok_iso_verif) then
     147       call check_isotopes_seq(q,ip1jmp1,'qminimum 168')
    156148       
    157149     
    … …  
    163155
    164156              ! on ajoute eau liquide en k en k             
    165               do ixt=1,ntraciso
    166                q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
     157              do ixt=1,nitr
     158               q(i,k,iTraPha(ixt,iq_liq))=q(i,k,iTraPha(ixt,iq_liq))
    167159     :              +zx_defau_diag(i,k,iq_liq)
    168      :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
     160     :              *q(i,k,iTraPha(ixt,iq_vap))/q_follow(i,k,iq_vap)
    169161              ! et on la retranche à la vapeur en k
    170                q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     162               q(i,k,iTraPha(ixt,iq_vap))=q(i,k,iTraPha(ixt,iq_vap))
    171163     :              -zx_defau_diag(i,k,iq_liq)
    172      :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
     164     :              *q(i,k,iTraPha(ixt,iq_vap))/q_follow(i,k,iq_vap)   
    173165              enddo !do ixt=1,niso
    174166              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
    … …  
    180172       enddo !do k=2,llm 
    181173
    182         if (ok_iso_verif) then
    183            call check_isotopes_seq(q,ip1jmp1,'qminimum 197')
    184         endif !if (ok_iso_verif) then
     174       call check_isotopes_seq(q,ip1jmp1,'qminimum 197')
    185175
    186       endif !if (ok_isotopes) then
     176      endif !if (niso > 0) then
    187177      !write(*,*) 'qminimum 188'
    188178     

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/vlsplt.F

    r2603 r3852  
    44
    55      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
    6       USE infotrac, ONLY: nqtot,nqdesc,iqfils
     6      USE infotrac, ONLY: nqtot, tracers, tra
    77c
    88c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    5454      SAVE temps1,temps2,temps3
    5555      INTEGER iminn,imaxx
    56       INTEGER ifils,iq2 ! CRisi
     56      INTEGER ichld,iq2 ! CRisi
     57      TYPE(tra), POINTER :: tr
    5758
    5859      REAL qmin,qmax
    … …  
    6162      DATA temps1,temps2,temps3/0.,0.,0./
    6263
     64       tr => tracers(iq)
    6365
    6466        zzpbar = 0.5 * pdt
    … …  
    8385      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    8486       
    85       if (nqdesc(iq).gt.0) then 
    86         do ifils=1,nqdesc(iq)
    87           iq2=iqfils(ifils,iq)
     87      if (tr%ndesc > 0) then 
     88        do ichld=1,tr%ndesc
     89          iq2=tr%idesc(ichld)
    8890          CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    8991        enddo 
    90       endif !if (nqfils(iq).gt.0) then
     92      endif !if (tr%ndesc > 0) then
    9193
    9294cprint*,'Entree vlx1'
    … …  
    122124      ENDDO
    123125      ! CRisi: aussi pour les fils
    124       if (nqdesc(iq).gt.0) then
    125       do ifils=1,nqdesc(iq)
    126         iq2=iqfils(ifils,iq)
     126      if(tr%ndesc > 0) then
     127      do ichld=1,tr%ndesc
     128        iq2=tr%idesc(ichld)
    127129        DO l=1,llm
    128130         DO ij=1,ip1jmp1
    … …  
    133135         ENDDO
    134136        ENDDO
    135       enddo !do ifils=1,nqdesc(iq)   
    136       endif ! if (nqdesc(iq).gt.0) then   
     137      enddo !do ichld=1,tr%ndesc
     138      endif ! if (tr%ndesc > 0)   
    137139
    138140      RETURN
    139141      END
    140142      RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
    141       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     143      USE infotrac, ONLY : nqtot, tracers, tra ! CRisi
    142144
    143145c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    179181      ! CRisi
    180182      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    181       INTEGER ifils,iq2 ! CRisi
     183      INTEGER ichld,iq2 ! CRisi
     184      TYPE(tra), POINTER :: tr
    182185
    183186      Logical extremum,first,testcpu
    … …  
    200203         first=.false.
    201204      ENDIF
     205
     206      tr => tracers(iq)
    202207
    203208c   calcul de la pente a droite et a gauche de la maille
    … …  
    450455      !write(*,*) 'vlsplt 326: iq,nqfils(iq)=',iq,nqfils(iq)
    451456     
    452       if (nqdesc(iq).gt.0) then 
    453        do ifils=1,nqdesc(iq)
    454          iq2=iqfils(ifils,iq)
     457      if (tr%ndesc > 0) then 
     458       do ichld=1,tr%ndesc
     459         iq2=tr%idesc(ichld)
    455460         DO l=1,llm
    456461          DO ij=iip2,ip1jm
    … …  
    460465          enddo   
    461466         enddo
    462         enddo !do ifils=1,nqdesc(iq)
    463         do ifils=1,nqfils(iq)
    464          iq2=iqfils(ifils,iq)
     467        enddo !do ichld=1,tr%ndesc
     468        do ichld=1,tr%nchld
     469         iq2=tr%idesc(ichld)
    465470         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
    466         enddo !do ifils=1,nqfils(iq)
    467       endif !if (nqfils(iq).gt.0) then
     471        enddo !do ichld=1,tr%nchld
     472      endif !if (tr%nchld > 0) then
    468473! end CRisi
    469474
    … …  
    489494      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    490495      ! puis on boucle en longitude
    491       if (nqdesc(iq).gt.0) then 
    492        do ifils=1,nqdesc(iq)
    493          iq2=iqfils(ifils,iq) 
     496      if (tr%ndesc > 0) then 
     497       do ichld=1,tr%ndesc
     498         iq2=tr%idesc(ichld) 
    494499         DO l=1,llm
    495500          DO ij=iip2+1,ip1jm
    … …  
    500505          enddo ! DO ij=ijb+iip1-1,ije,iip1
    501506         enddo !DO l=1,llm
    502         enddo !do ifils=1,nqdesc(iq)
    503       endif !if (nqfils(iq).gt.0) then
     507        enddo !do ichld=1,tr%ndesc
     508      endif !if (tr%ndesc > 0) then
    504509
    505510c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    … …  
    510515      END
    511516      RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
    512       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     517      USE infotrac, ONLY : nqtot, tracers, tra ! CRisi
    513518c
    514519c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    562567
    563568      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    564       INTEGER ifils,iq2 ! CRisi
    565 
     569      INTEGER ichld,iq2 ! CRisi
     570      TYPE(tra), POINTER :: tr
    566571c
    567572c
    … …  
    590595      ENDIF
    591596
     597      tr => tracers(iq)
    592598c
    593599cPRINT*,'CALCUL EN LATITUDE'
    … …  
    770776      !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq)
    771777   
    772       if (nqfils(iq).gt.0) then 
    773        do ifils=1,nqdesc(iq)
    774          iq2=iqfils(ifils,iq)
     778      if (tr%ndesc > 0) then 
     779       do ichld=1,tr%ndesc
     780         iq2=tr%idesc(ichld)
    775781         DO l=1,llm
    776782         DO ij=1,ip1jmp1
    … …  
    781787          enddo   
    782788         enddo
    783         enddo !do ifils=1,nqdesc(iq)
    784 
    785         do ifils=1,nqfils(iq)
    786          iq2=iqfils(ifils,iq)
     789        enddo !do ichld=1,tr%ndesc
     790
     791        do ichld=1,tr%nchld
     792         iq2=tr%idesc(ichld)
    787793         call vly(Ratio,pente_max,masseq,qbyv,iq2)
    788         enddo !do ifils=1,nqfils(iq)
    789       endif !if (nqfils(iq).gt.0) then
     794        enddo !do ichld=1,tr%nchld
     795      endif !if (tr%ndesc > 0)
    790796
    791797      DO l=1,llm
    … …  
    855861 
    856862! retablir les fils en rapport de melange par rapport a l'air:
    857       if (nqfils(iq).gt.0) then 
    858        do ifils=1,nqdesc(iq)
    859          iq2=iqfils(ifils,iq) 
     863      if (tr%ndesc > 0) then 
     864       do ichld=1,tr%ndesc
     865         iq2=tr%idesc(ichld) 
    860866         DO l=1,llm
    861867          DO ij=1,ip1jmp1
    … …  
    863869          enddo
    864870         enddo
    865         enddo !do ifils=1,nqdesc(iq)
    866       endif !if (nqfils(iq).gt.0) then
     871        enddo !do ichld=1,tr%ndesc
     872      endif !if (tr%ndesc > 0)
    867873
    868874      !write(*,*) 'vly 853: sortie'
    … …  
    871877      END
    872878      RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
    873       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     879      USE infotrac, ONLY : nqtot, tracers, tra ! CRisi
    874880c
    875881c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    907913
    908914      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    909       INTEGER ifils,iq2 ! CRisi
     915      INTEGER ichld,iq2 ! CRisi
     916      TYPE(tra), POINTER :: tr
    910917
    911918      LOGICAL testcpu
    … …  
    923930
    924931      !write(*,*) 'vlz 923: entree'
     932
     933      tr => tracers(iq)
    925934
    926935#ifdef BIDON
    … …  
    9921001! Il faut faire ça avant d'avoir mis à jour q et masse
    9931002      !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
    994       if (nqfils(iq).gt.0) then 
    995        do ifils=1,nqdesc(iq)
    996          iq2=iqfils(ifils,iq)
     1003      if (tr%ndesc > 0) then 
     1004       do ichld=1,tr%ndesc
     1005         iq2=tr%idesc(ichld)
    9971006         DO l=1,llm
    9981007          DO ij=1,ip1jmp1
    … …  
    10011010          enddo   
    10021011         enddo
    1003         enddo !do ifils=1,nqdesc(iq)
     1012        enddo !do ichld=1,tr%ndesc
    10041013       
    1005         do ifils=1,nqfils(iq)
    1006          iq2=iqfils(ifils,iq)         
     1014        do ichld=1,tr%nchld
     1015         iq2=tr%idesc(ichld)         
    10071016         call vlz(Ratio,pente_max,masseq,wq,iq2)
    1008         enddo !do ifils=1,nqfils(iq)
    1009       endif !if (nqfils(iq).gt.0) then
     1017        enddo !do ichld=1,tr%nchld
     1018      endif !if (tr%ndesc > 0)
    10101019! end CRisi 
    10111020
    … …  
    10201029
    10211030! retablir les fils en rapport de melange par rapport a l'air:
    1022       if (nqfils(iq).gt.0) then 
    1023        do ifils=1,nqdesc(iq)
    1024          iq2=iqfils(ifils,iq) 
     1031      if (tr%ndesc > 0) then 
     1032       do ichld=1,tr%ndesc
     1033         iq2=tr%idesc(ichld)
    10251034         DO l=1,llm
    10261035          DO ij=1,ip1jmp1
    … …  
    10281037          enddo
    10291038         enddo
    1030         enddo !do ifils=1,nqdesc(iq)
    1031       endif !if (nqfils(iq).gt.0) then
     1039        enddo !do ichld=1,tr%ndesc
     1040      endif !if (tr%ndesc > 0)
    10321041      !write(*,*) 'vlsplt 1032'
    10331042

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d/vlspltqs.F

    r2603 r3852  
    44       SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
    55     ,                                  p,pk,teta,iq             )
    6        USE infotrac, ONLY: nqtot,nqdesc,iqfils
     6       USE infotrac, ONLY: nqtot, tracers, tra
    77c
    88c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
    … …  
    4545c
    4646      INTEGER i,ij,l,j,ii
    47       INTEGER ifils,iq2 ! CRisi
     47      INTEGER ichld,iq2 ! CRisi
     48      TYPE(tra), POINTER :: tr
    4849c
    4950      REAL qsat(ip1jmp1,llm)
    … …  
    8485        rtt  = 273.16
    8586
     87        tr => tracers(iq)
     88
    8689c-- Calcul de Qsat en chaque point
    8790c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
    … …  
    121124      CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
    122125      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    123       if (nqdesc(iq).gt.0) then 
    124        do ifils=1,nqdesc(iq)
    125         iq2=iqfils(ifils,iq)
     126      if (tr%ndesc > 0) then 
     127       do ichld=1,tr%ndesc
     128        iq2=tr%idesc(ichld)
    126129        CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    127130       enddo 
    128       endif !if (nqfils(iq).gt.0) then
     131      endif !if (tr%ndesc > 0)
    129132
    130133c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    … …  
    162165      ENDDO
    163166      ! CRisi: aussi pour les fils
    164       if (nqdesc(iq).gt.0) then
    165       do ifils=1,nqdesc(iq)
    166         iq2=iqfils(ifils,iq)
     167      if (tr%ndesc > 0) then
     168      do ichld=1,tr%ndesc
     169        iq2=tr%idesc(ichld)
    167170        DO l=1,llm
    168171         DO ij=1,ip1jmp1
    … …  
    173176         ENDDO
    174177        ENDDO
    175       enddo !do ifils=1,nqdesc(iq) 
    176       endif ! if (nqfils(iq).gt.0) then
     178      enddo !do ichld=1,tr%ndesc
     179      endif ! if (tr%ndesc > 0)
    177180      !write(*,*) 'vlspltqs 183: fin de la routine'
    178181
    … …  
    180183      END
    181184      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
    182       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     185      USE infotrac, ONLY : nqtot, tracers, tra ! CRisi
    183186
    184187c
    … …  
    218221      ! CRisi
    219222      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    220       INTEGER ifils,iq2 ! CRisi
     223      INTEGER ichld,iq2 ! CRisi
     224      TYPE(tra), POINTER :: tr
    221225
    222226      Logical first,testcpu
    … …  
    238242         first=.false.
    239243      ENDIF
     244
     245      tr => tracers(iq)
    240246
    241247c   calcul de la pente a droite et a gauche de la maille
    … …  
    485491      !write(*,*) 'vlspltqs 326: iq,nqfils(iq)=',iq,nqfils(iq)
    486492     
    487       if (nqfils(iq).gt.0) then 
    488        do ifils=1,nqdesc(iq)
    489          iq2=iqfils(ifils,iq)
     493      if (tr%ndesc > 0) then
     494       do ichld=1,tr%ndesc
     495         iq2=tr%idesc(ichld)
    490496         DO l=1,llm
    491497          DO ij=iip2,ip1jm
    … …  
    495501          enddo   
    496502         enddo
    497         enddo !do ifils=1,nqdesc(iq)
    498         do ifils=1,nqfils(iq)
    499          iq2=iqfils(ifils,iq)
     503        enddo !do ichld=1,nqdesc(iq)
     504        do ichld=1,tr%nchld
     505         iq2=tr%idesc(ichld)
    500506         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
    501         enddo !do ifils=1,nqfils(iq)
    502       endif !if (nqfils(iq).gt.0) then
     507        enddo !do ichld=1,tr%nchld
     508      endif !if (tr%ndesc > 0)
    503509! end CRisi
    504510
    … …  
    523529      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    524530      ! puis on boucle en longitude
    525       if (nqdesc(iq).gt.0) then 
    526        do ifils=1,nqdesc(iq)
    527          iq2=iqfils(ifils,iq) 
     531      if (tr%ndesc > 0) then
     532       do ichld=1,tr%ndesc
     533         iq2=tr%idesc(ichld)
    528534         DO l=1,llm
    529535          DO ij=iip2+1,ip1jm
    … …  
    534540          enddo ! DO ij=ijb+iip1-1,ije,iip1
    535541         enddo !DO l=1,llm
    536         enddo !do ifils=1,nqdesc(iq)
    537       endif !if (nqfils(iq).gt.0) then
     542        enddo !do ichld=1,tr%ndesc
     543      endif !if (tr%ndesc > 0)
    538544
    539545c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    … …  
    544550      END
    545551      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
    546       USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     552      USE infotrac, ONLY : nqtot, tracers, tra ! CRisi
    547553c
    548554c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    598604
    599605      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    600       INTEGER ifils,iq2 ! CRisi
     606      INTEGER ichld,iq2 ! CRisi
     607      TYPE(tra), POINTER :: tr
    601608c
    602609c
    … …  
    623630      ENDIF
    624631
     632      tr => tracers(iq)
    625633c
    626634
    … …  
    796804      !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
    797805   
    798       if (nqfils(iq).gt.0) then 
    799        do ifils=1,nqdesc(iq)
    800          iq2=iqfils(ifils,iq)
     806      if (tr%ndesc > 0) then
     807       do ichld=1,tr%ndesc
     808         iq2=tr%idesc(ichld)
    801809         DO l=1,llm
    802810         DO ij=1,ip1jmp1
    … …  
    805813          enddo   
    806814         enddo
    807         enddo !do ifils=1,nqdesc(iq)
    808 
    809         do ifils=1,nqfils(iq)
    810          iq2=iqfils(ifils,iq)
     815        enddo !do ichld=1,tr%ndesc
     816
     817        do ichld=1,tr%nchld
     818         iq2=tr%idesc(ichld)
    811819         !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
    812820         call vly(Ratio,pente_max,masseq,qbyv,iq2)
    813         enddo !do ifils=1,nqfils(iq)
    814       endif !if (nqfils(iq).gt.0) then
     821        enddo !do ichld=1,tr%nchld
     822      endif !if (tr%ndesc > 0)
    815823
    816824      DO l=1,llm
    … …  
    868876
    869877! retablir les fils en rapport de melange par rapport a l'air:
    870       if (nqdesc(iq).gt.0) then 
    871        do ifils=1,nqdesc(iq)
    872          iq2=iqfils(ifils,iq) 
     878      if (tr%ndesc > 0) then
     879       do ichld=1,tr%ndesc
     880         iq2=tr%idesc(ichld)
    873881         DO l=1,llm
    874882          DO ij=1,ip1jmp1
    … …  
    876884          enddo
    877885         enddo
    878         enddo !do ifils=1,nqdesc(iq)
    879       endif !if (nqfils(iq).gt.0) then
     886        enddo !do ichld=1,tr%ndesc
     887      endif !if (tr%ndesc > 0)
    880888      !write(*,*) 'vly 879'
    881889

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/infotrac.F90

    r3851 r3852  
    1 ! $Id$
    2 !
    31MODULE infotrac
    42
    5 ! nqtot : total number of tracers and higher order of moment, water vapor and liquid included
    6   INTEGER, SAVE :: nqtot
    7 !CR: on ajoute le nombre de traceurs de l eau
    8   INTEGER, SAVE :: nqo
    9 
    10 ! nbtr : number of tracers not including higher order of moment or water vapor or liquid
    11 !        number of tracers used in the physics
    12   INTEGER, SAVE :: nbtr
    13 
    14 ! CRisi: nb traceurs pères= directement advectés par l'air
    15   INTEGER, SAVE :: nqperes
    16 
    17 ! Name variables
    18   CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
    19   CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics
    20 
    21 ! iadv  : index of trasport schema for each tracer
    22   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iadv
    23 
    24 ! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the
    25 !         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code.
    26   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
    27 
    28 ! CRisi: tableaux de fils
    29   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqfils
    30   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqdesc ! nombres de fils + nombre de tous les petits fils sur toutes les générations
    31   INTEGER, SAVE :: nqdesc_tot
    32   INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE    :: iqfils
    33   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iqpere
    34   REAL :: qperemin,masseqmin,ratiomin ! MVals et CRisi
    35   PARAMETER (qperemin=1e-16,masseqmin=1e-16,ratiomin=1e-16) ! MVals
    36 
    37 ! conv_flg(it)=0 : convection desactivated for tracer number it
    38   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: conv_flg
    39 ! pbl_flg(it)=0  : boundary layer diffusion desactivaded for tracer number it
    40   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: pbl_flg
    41 
    42   CHARACTER(len=4),SAVE :: type_trac
    43   CHARACTER(len=8),DIMENSION(:),ALLOCATABLE, SAVE :: solsym
    44    
    45 ! CRisi: cas particulier des isotopes
    46   LOGICAL,SAVE :: ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso
    47   INTEGER :: niso_possibles   
    48   PARAMETER ( niso_possibles=5)
    49   REAL, DIMENSION (niso_possibles),SAVE :: tnat,alpha_ideal
    50   LOGICAL, DIMENSION(niso_possibles),SAVE ::  use_iso
    51   INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  iqiso ! donne indice iq en fn de (ixt,phase)
    52   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_num ! donne numéro iso entre 1 et niso_possibles en fn de nqtot
    53   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_indnum ! donne numéro iso entre 1 et niso effectif en fn de nqtot
    54   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  zone_num ! donne numéro de la zone de tracage en fn de nqtot
    55   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  phase_num ! donne numéro de la zone de tracage en fn de nqtot
    56   INTEGER, DIMENSION(niso_possibles), SAVE :: indnum_fn_num ! donne indice entre entre 1 et niso en fonction du numéro d isotope entre 1 et niso_possibles
    57   INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  index_trac ! numéro ixt en fn izone, indnum entre 1 et niso
    58   INTEGER,SAVE :: niso,ntraceurs_zone,ntraciso
    59 
     3  USE       strings_mod, ONLY: msg, find, strIdx,  strFind,  strHead, dispTable, cat, get_in,  &
     4                              fmsg, test, int2str, strParse, strTail, strReduce, strStack, modname, testFile
     5  USE readTracFiles_mod, ONLY: readTracersFiles, getKey_init, nphases, delPhase, aliasTracer, &
     6                        tran0, readIsotopesFile, getKey, known_phases, addPhase, indexUpdate
     7  USE trac_types_mod,    ONLY: tra, iso, kys
     8
     9  IMPLICIT NONE
     10
     11  PRIVATE
     12
     13  !=== FOR TRACERS:
     14  PUBLIC :: tra,   tracers,  type_trac                     !--- Derived type, full database, tracers type keyword
     15  PUBLIC :: nqtot,   nbtr,   nqo                           !--- Main dimensions
     16  PUBLIC :: infotrac_init, aliasTracer                     !--- Initialization, tracers alias creation
     17  PUBLIC :: itr_indice                                     !--- Indexes of the tracers passed to phytrac
     18  PUBLIC :: niadv                                          !--- Indexes of true tracers (<=nqtot, such that iadv(idx)>0)
     19  PUBLIC :: solsym, conv_flg, pbl_flg
     20
     21  !=== FOR ISOTOPES: General
     22  !--- General
     23  PUBLIC :: iso, isotopes, nbIso                           !--- Derived type, full isotopes families database + nb of families
     24  PUBLIC :: isoSelect , ixIso                              !--- Isotopes family selection tool + selected family index
     25  !=== FOR ISOTOPES: Specific to H2O isotopes
     26  PUBLIC :: iH2O, tnat, alpha_ideal                        !--- H2O isotopes index, natural abundance, fractionning coeff.
     27  !=== FOR ISOTOPES: Depending on selected isotopes family
     28  PUBLIC :: isotope, isoKeys                               !--- Selected isotopes database + associated keys (cf. getKey)
     29  PUBLIC :: isoName, isoZone, isoPhas                      !--- Isotopes and tagging zones names, phases
     30  PUBLIC :: niso, nzon, npha, nitr                         !---  " " numbers + isotopes & tagging tracers number
     31  PUBLIC :: iZonIso, iTraPha                               !--- 2D index tables to get "iq" index
     32  PUBLIC :: isoCheck                                       !--- Run isotopes checking routines
     33
     34  !=== FOR BOTH TRACERS AND ISOTOPES
     35  PUBLIC :: getKey                                         !--- Get a key from "tracers" or "isotope"
     36
     37  !=== FOR STRATOSPHERIC AEROSOLS
    6038#ifdef CPP_StratAer
    61 !--CK/OB for stratospheric aerosols
    62   INTEGER, SAVE :: nbtr_bin
    63   INTEGER, SAVE :: nbtr_sulgas
    64   INTEGER, SAVE :: id_OCS_strat
    65   INTEGER, SAVE :: id_SO2_strat
    66   INTEGER, SAVE :: id_H2SO4_strat
    67   INTEGER, SAVE :: id_BIN01_strat
    68   INTEGER, SAVE :: id_TEST_strat
    69 #endif
    70  
     39  PUBLIC :: nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat
     40#endif
     41
     42  INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect
     43
     44!=== CONVENTIONS FOR TRACERS NUMBERS:
     45!  |--------------------+----------------------+-----------------+---------------+----------------------------|
     46!  | water in different |    water tagging     |  water isotopes | other tracers | additional tracers moments |
     47!  | phases: H2O-[gls]  |      isotopes        |                 |               |  for higher order schemes  |
     48!  |--------------------+----------------------+-----------------+---------------+----------------------------|
     49!  |                    |                      |                 |               |                            |
     50!  |<--     nqo      -->|<-- nqo*niso* nzon -->|<-- nqo*niso  -->|<--  nbtr   -->|<--        (nmom)        -->|         
     51!  |                    |                                        |                                            |
     52!  |                    |<-- nqo*niso*(nzon+1)  =   nqo*nitr  -->|<--    nqtottr = nbtr + nmom             -->|
     53!  |                                                                             = nqtot - nqo*(nitr+1)       |
     54!  |                                                                                                          |
     55!  |<--                        nqtrue  =  nbtr + nqo*(nitr+1)                 -->|                            |
     56!  |                                                                                                          |
     57!  |<--                        nqtot   =  nqtrue + nmom                                                    -->|
     58!  |                                                                                                          |
     59!  |----------------------------------------------------------------------------------------------------------|
     60! NOTES FOR THIS TABLE:
     61!  * The used "niso", "nzon" and "nitr" are the H2O components of "isotopes(ip)"  (isotopes(ip)%prnt == 'H2O'),
     62!    since water is so far the sole tracers family removed from the main tracers table.
     63!  * For water, "nqo" is equal to the more general field "isotopes(ip)%npha".
     64!  * "niso", "nzon", "nitr", "npha" are defined for other isotopic tracers families, if any.
     65!
     66!=== TRACERS DESCRIPTOR: DERIVED TYPE EMBEDDING MOST OF THE USEFUL QUANTITIES (LENGTH: nqtot)
     67!    Each entry is accessible using "%" sign.
     68!  |------------+-------------------------------------------------+-------------+------------------------+
     69!  |  entry     | Meaning                                         | Former name | Possible values        |
     70!  |------------+-------------------------------------------------+-------------+------------------------+
     71!  | name       | Name (short)                                    | tname       |                        |
     72!  | nam1       | Name of the 1st generation ancestor             | /           |                        |
     73!  | prnt       | Name of the parent                              | /           |                        |
     74!  | lnam       | Long name (with adv. scheme suffix) for outputs | ttext       |                        |
     75!  | type       | Type (so far: tracer or tag)                    | /           | tracer,tag             |
     76!  | phas       | Phases list ("g"as / "l"iquid / "s"olid)        | /           | [g][l][s]              |
     77!  | iadv       | Advection scheme number                         | iadv        | 1-20,30 exc. 3-9,15,19 |
     78!  | igen       | Generation (>=1)                                | /           |                        |
     79!  | itr        | Index in "tr_seri" (0: absent from physics)     | cf. niadv   | 1:nqtottr              |
     80!  | iprnt      | Index of the parent tracer                      | iqpere      | 1:nqtot                |
     81!  | idesc      | Indexes of the childs (all generations)         | iqfils      | 1:nqtot                |
     82!  | ndesc      | Number of the descendants (all generations)     | nqdesc      | 1:nqtot                |
     83!  | nchld      | Number of childs (first generation only)        | nqfils      | 1:nqtot                |
     84!  | keys       | key/val pairs accessible with "getKey" routine  | /           |                        |
     85!  | iso_num    | Isotope name  index in iso(igr)%name(:)         | iso_indnum  | 1:niso                 |
     86!  | iso_zon    | Isotope zone  index in iso(igr)%zone(:)         | zone_num    | 1:nzon                 |
     87!  | iso_pha    | Isotope phase index in iso(igr)%phas            | phase_num   | 1:npha                 |
     88!  +------------+-------------------------------------------------+-------------+------------------------+
     89!
     90!=== ISOTOPES DESCRIPTOR: DERIVED TYPE EMBEDDING MOST OF THE USEFUL QUANTITIES (LENGTH: NUMBER OF ISOTOPES FAMILIES USED)
     91!    Each entry is accessible using "%" sign.
     92!  |------------+-------------------------------------------------+-------------+-----------------------+
     93!  |  entry     | Meaning                                         | Former name | Possible values       |
     94!  |------------+-------------------------------------------------+-------------+-----------------------+
     95!  | prnt       | Parent tracer (isotopes family name)            |             |                       |
     96!  | trac, nitr | Isotopes & tagging tracers + number of elements |             |                       |
     97!  | zone, nzon | Geographic tagging zones   + number of elements |             |                       |
     98!  | phas, npha | Phases list                + number of elements |             | [g][l][s], 1:3        |
     99!  | niso       | Number of isotopes, excluding tagging tracers   |             |                       |
     100!  | iTraPha    | Index in "xt" = f(iname(niso+1:nitr),iphas)     | iqiso       | 1:niso                |
     101!  | iZonIso    | Index in "xt" = f(izone, iname(1:niso))         | index_trac  | 1:nzon                |
     102!  |------------+-------------------------------------------------+-------------+-----------------------+
     103
     104
     105
     106  !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES
     107  INTEGER,            SAVE :: nqtot, &                     !--- Tracers nb in dynamics (incl. higher moments & water)
     108                              nbtr,  &                     !--- Tracers nb in physics  (excl. higher moments & water)
     109                              nqo,   &                     !--- Number of water phases
     110                              nbIso                        !--- Number of available isotopes family
     111  CHARACTER(LEN=256), SAVE :: type_trac                    !--- Keyword for tracers type
     112!$OMP THREADPRIVATE(nqtot, nbtr, nqo, nbIso, type_trac)
     113
     114  !=== DERIVED TYPES EMBEDDING MOST INFORMATIONS ABOUT TRACERS AND ISOTOPES FAMILIES
     115  TYPE(tra), TARGET,  SAVE, ALLOCATABLE ::  tracers(:)      !=== TRACERS DESCRIPTORS VECTOR
     116  TYPE(iso), TARGET,  SAVE, ALLOCATABLE :: isotopes(:)      !=== ISOTOPES PARAMETERS VECTOR
     117!$OMP THREADPRIVATE(tracers, isotopes)
     118
     119  !=== ALIASES FOR CURRENTLY SELECTED ISOTOPES FAMILY OF VARIABLES EMBEDDED IN THE VECTOR "isotopes"
     120  TYPE(iso),          SAVE, POINTER :: isotope             !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR
     121  INTEGER,            SAVE          :: ixIso, iH2O         !--- Index of the selected isotopes family and H2O family
     122  LOGICAL,            SAVE, POINTER :: isoCheck            !--- Flag to trigger the checking routines
     123  TYPE(kys),          SAVE, POINTER :: isoKeys(:)          !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName)
     124  CHARACTER(LEN=256), SAVE, POINTER :: isoName(:),       & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY
     125                                       isoZone(:),       & !--- TAGGING ZONES  FOR THE CURRENTLY SELECTED FAMILY
     126                                       isoPhas             !--- USED PHASES    FOR THE CURRENTLY SELECTED FAMILY
     127  INTEGER,            SAVE          :: niso, nzon, npha, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES
     128                                       nitr                !--- NUMBER OF ISOTOPES + ISOTOPIC TAGGING TRACERS
     129  INTEGER,            SAVE, POINTER :: iZonIso(:,:)        !--- INDEX IN "isoTrac" AS f(tagging zone, isotope)
     130  INTEGER,            SAVE, POINTER :: iTraPha(:,:)        !=== INDEX IN "isoTrac" AS f(isotopic tracer, phase)
     131!$OMP THREADPRIVATE(isotope, ixIso,iH2O, isoCheck, isoKeys, isoName,isoZone,isoPhas, niso,nzon,npha,nitr, iZonIso,iTraPha)
     132
     133  !=== VARIABLES EMBEDDED IN "tracers", BUT DUPLICATED, AS THEY ARE RATHER FREQUENTLY USED + VARIABLES FOR INCA
     134  REAL,               SAVE, ALLOCATABLE ::     tnat(:),  & !--- Natural relative abundance of water isotope        (niso)
     135                                        alpha_ideal(:)     !--- Ideal fractionning coefficient (for initial state) (niso)
     136  INTEGER,            SAVE, ALLOCATABLE :: conv_flg(:),  & !--- Convection     activation ; needed for INCA        (nbtr)
     137                                            pbl_flg(:),  & !--- Boundary layer activation ; needed for INCA        (nbtr)
     138                                         itr_indice(:),  & !--- Indexes of the tracers passed to phytrac        (nqtottr)
     139                                              niadv(:)
     140  CHARACTER(LEN=8),   SAVE, ALLOCATABLE ::   solsym(:)     !--- Names from INCA                                    (nbtr)
     141!OMP THREADPRIVATE(tnat, alpha_ideal, conv_flg, pbl_flg, itr_indice, solsym)
     142
     143#ifdef CPP_StratAer
     144  !=== SPECIFIC TO STRATOSPHERIC AEROSOLS (CK/OB)
     145  INTEGER, SAVE :: nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat
     146!OMP THREADPRIVATE(nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat)
     147#endif
     148
    71149CONTAINS
    72150
    73   SUBROUTINE infotrac_init
    74     USE control_mod, ONLY: planet_type, config_inca
     151SUBROUTINE infotrac_init
     152  USE control_mod, ONLY: planet_type, config_inca
    75153#ifdef REPROBUS
    76     USE CHEM_REP, ONLY : Init_chem_rep_trac
    77 #endif
    78     IMPLICIT NONE
    79 !=======================================================================
     154  USE chem_rep,    ONLY: Init_chem_rep_trac
     155#endif
     156!==============================================================================================================================
    80157!
    81158!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
    82159!   -------
    83 !   Modif special traceur F.Forget 05/94
    84 !   Modif M-A Filiberti 02/02 lecture de traceur.def
     160!
     161!   Modifications:
     162!   --------------
     163!   05/94: F.Forget      Modif special traceur
     164!   02/02: M-A Filiberti Lecture de traceur.def
     165!   06/20: D. Cugnet     Nouveaux tracer.def et tracer_*.def + encapsulation (types tr et iso)
    85166!
    86167!   Objet:
    … …  
    88169!   GCM LMD nouvelle grille
    89170!
    90 !=======================================================================
     171!==============================================================================================================================
    91172!   ... modification de l'integration de q ( 26/04/94 ) ....
    92 !-----------------------------------------------------------------------
    93 ! Declarations
    94 
    95     INCLUDE "dimensions.h"
    96     INCLUDE "iniprint.h"
    97 
     173!------------------------------------------------------------------------------------------------------------------------------
     174! Declarations:
     175!  INCLUDE "dimensions.h"
     176
     177!------------------------------------------------------------------------------------------------------------------------------
    98178! Local variables
    99     INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv  ! index of horizontal trasport schema
    100     INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv  ! index of vertical trasport schema
    101 
    102     INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv_inca  ! index of horizontal trasport schema
    103     INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv_inca  ! index of vertical trasport schema
    104 
    105     CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
    106     CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_transp ! transporting fluid short name: CRisi
    107     CHARACTER(len=3), DIMENSION(30) :: descrq
    108     CHARACTER(len=1), DIMENSION(3)  :: txts
    109     CHARACTER(len=2), DIMENSION(9)  :: txtp
    110     CHARACTER(len=23)               :: str1,str2
    111  
    112     INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
    113     INTEGER :: iq, new_iq, iiq, jq, ierr
    114     INTEGER :: ifils,ipere,generation ! CRisi
    115     LOGICAL :: continu,nouveau_traceurdef
    116     INTEGER :: IOstatus ! gestion de la retrocompatibilite de traceur.def
    117     CHARACTER(len=15) :: tchaine   
    118 
    119     character(len=*),parameter :: modname="infotrac_init"
    120 !-----------------------------------------------------------------------
     179  INTEGER, ALLOCATABLE :: hadv(:), hadv_inca(:), &                   !--- Horizontal/vertical transport scheme number
     180                          vadv(:), vadv_inca(:)                      !--- + specific INCA versions
     181  CHARACTER(LEN=1)   :: ph                                           !--- Phase
     182  CHARACTER(LEN=2)   ::   suff(9)                                    !--- Suffixes for schemes of order 3 or 4 (Prather)
     183  CHARACTER(LEN=3)   :: descrq(30)                                   !--- Advection scheme description
     184  CHARACTER(LEN=4)   :: oldH2O(3)                                    !--- Old water names
     185  CHARACTER(LEN=256) :: newH2O, iname, isoPhase                      !--- New water and isotope names, phases list
     186  CHARACTER(LEN=256) :: msg1, msg2                                   !--- Strings for messages
     187  CHARACTER(LEN=256), ALLOCATABLE, DIMENSION(:) :: &                 !--- Temporary storage
     188             isoName, isoZone, tra0, zon0, tag0, n, p, z, str
     189  INTEGER :: fType                                                   !--- Tracers description file type ; 0: none
     190                                                                     !--- 1: "traceur.def"  2: "tracer.def"  3: "tracer_*.def"
     191  INTEGER :: nqtrue                                                  !--- Tracers nb from tracer.def (no higher order moments)
     192  INTEGER :: iad                                                     !--- Advection scheme
     193  INTEGER :: iH2O                                                    !--- Index in "isotopes(:)" of H2O family
     194  INTEGER :: ic,ip,iq,jq, it,nt, im,nm, ix, iz, niso, nzone, ntiso   !--- Indexes and temporary variables
     195  LOGICAL, ALLOCATABLE :: lisoGen2(:), &                             !--- Mask for second generation isotopes
     196                          lisoName(:), &                             !--- Mask for water isotopes
     197                          lisoZone(:), ll(:)                         !--- Mask for water isotopes tagging tracers
     198  LOGICAL :: lerr
     199  TYPE(tra), ALLOCATABLE, TARGET :: ttr(:)
     200  TYPE(tra), POINTER             :: t1, t(:)
     201  TYPE(iso), POINTER             :: s
     202!------------------------------------------------------------------------------------------------------------------------------
    121203! Initialization :
    122 !
    123     txts=(/'x','y','z'/)
    124     txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/)
    125 
    126     descrq(14)='VLH'
    127     descrq(10)='VL1'
    128     descrq(11)='VLP'
    129     descrq(12)='FH1'
    130     descrq(13)='FH2'
    131     descrq(16)='PPM'
    132     descrq(17)='PPS'
    133     descrq(18)='PPP'
    134     descrq(20)='SLP'
    135     descrq(30)='PRA'
    136    
    137 
    138     ! Coherence test between parameter type_trac, config_inca and preprocessing keys
    139     IF (type_trac=='inca') THEN
    140        WRITE(lunout,*) 'You have choosen to couple with INCA chemestry model : type_trac=', &
    141             type_trac,' config_inca=',config_inca
    142        IF (config_inca/='aero' .AND. config_inca/='aeNP' .AND. config_inca/='chem') THEN
    143           WRITE(lunout,*) 'Incoherence between type_trac and config_inca. Model stops. Modify run.def'
    144           CALL abort_gcm('infotrac_init','Incoherence between type_trac and config_inca',1)
    145        END IF
     204!------------------------------------------------------------------------------------------------------------------------------
     205  modname = 'infotrac_init'
     206  type_trac='lmdz'!'lmdz,inca'
     207  suff          = ['x ','y ','z ','xx','xy','xz','yy','yz','zz']
     208  descrq( 1: 2) = ['LMV','BAK']
     209  descrq(10:20) = ['VL1','VLP','FH1','FH2','VLH','   ','PPM','PPS','PPP','   ','SLP']
     210  descrq(30)    =  'PRA'
     211  oldH2O        = ['H2Ov','H2Ol','H2Oi']
     212
     213  !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION
     214  CALL msg('type_trac='//TRIM(type_trac))
     215  IF(strParse(type_trac, ',', str, n=nt)) CALL abort_gcm(modname,'can''t parse "type_trac = '//TRIM(type_trac)//'"',1)
     216  DO it = 1, nt                                                      !--- nt>1 if "type_trac" is a coma-separated keywords list
     217    msg1 = 'For type_trac = "'//TRIM(str(it))//'":'
     218    SELECT CASE(str(it))
     219      CASE('inca'); CALL msg(TRIM(msg1)//' coupling with INCA chemistry model, config_inca='//config_inca)
     220      CASE('repr'); CALL msg(TRIM(msg1)//' coupling with REPROBUS chemistry model')
     221      CASE('co2i'); CALL msg(TRIM(msg1)//' you have chosen to run with CO2 cycle')
     222      CASE('coag'); CALL msg(TRIM(msg1)//' tracers are treated for COAGULATION tests')
     223      CASE('lmdz'); CALL msg(TRIM(msg1)//' tracers are treated in LMDZ only')
     224      CASE DEFAULT
     225        CALL abort_gcm(modname,'type_trac='//TRIM(str(it))//' not possible yet.',1)
     226    END SELECT
     227  END DO
     228
     229  !--- COHERENCE TEST BETWEEN "type_trac", "config_inca" AND PREPROCESSING KEYS
     230  DO it=1,nt
     231    SELECT CASE(type_trac)
     232      CASE('inca'); IF(ALL(['aero', 'aeNP', 'chem']/=config_inca)) &
     233        CALL abort_gcm(modname, 'Mismatch between type_trac and config_inca. Please modify "run.def"',1)
    146234#ifndef INCA
    147        WRITE(lunout,*) 'To run this option you must add cpp key INCA and compile with INCA code'
    148        CALL abort_gcm('infotrac_init','You must compile with cpp key INCA',1)
    149 #endif
    150     ELSE IF (type_trac=='repr') THEN
    151        WRITE(lunout,*) 'You have choosen to couple with REPROBUS chemestry model : type_trac=', type_trac
     235        CALL abort_gcm(modname, 'You must add cpp key INCA and compile with INCA code',1)
     236#endif
     237      CASE('repr')
    152238#ifndef REPROBUS
    153        WRITE(lunout,*) 'To run this option you must add cpp key REPROBUS and compile with REPRPBUS code'
    154        CALL abort_gcm('infotrac_init','You must compile with cpp key REPROBUS',1)
    155 #endif
    156     ELSE IF (type_trac == 'co2i') THEN
    157        WRITE(lunout,*) 'You have chosen to run with CO2 cycle: type_trac=', type_trac
    158     ELSE IF (type_trac == 'coag') THEN
    159        WRITE(lunout,*) 'Tracers are treated for COAGULATION tests : type_trac=', type_trac
     239        CALL abort_gcm(modname, 'You must add cpp key REPROBUS and compile with REPROBUS code',1)
     240#endif
     241      CASE('coag')
    160242#ifndef CPP_StratAer
    161        WRITE(lunout,*) 'To run this option you must add cpp key StratAer and compile with StratAer code'
    162        CALL abort_gcm('infotrac_init','You must compile with cpp key StratAer',1)
    163 #endif
    164     ELSE IF (type_trac == 'lmdz') THEN
    165        WRITE(lunout,*) 'Tracers are treated in LMDZ only : type_trac=', type_trac
    166     ELSE
    167        WRITE(lunout,*) 'type_trac=',type_trac,' not possible. Model stops'
    168        CALL abort_gcm('infotrac_init','bad parameter',1)
    169     END IF
    170 
    171     ! Test if config_inca is other then none for run without INCA
    172     IF (type_trac/='inca' .AND. config_inca/='none') THEN
    173        WRITE(lunout,*) 'config_inca will now be changed to none as you do not couple with INCA model'
    174        config_inca='none'
    175     END IF
    176 
    177 !-----------------------------------------------------------------------
    178 !
    179 ! 1) Get the true number of tracers + water vapor/liquid
    180 !    Here true tracers (nqtrue) means declared tracers (only first order)
    181 !
    182 !-----------------------------------------------------------------------
    183     IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag' .OR. type_trac == 'co2i') THEN
    184        OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
    185        IF(ierr.EQ.0) THEN
    186           WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
    187           READ(90,*) nqtrue
    188           write(lunout,*) 'nqtrue=',nqtrue
    189        ELSE
    190           WRITE(lunout,*) trim(modname),': Problem in opening traceur.def'
    191           WRITE(lunout,*) trim(modname),': WARNING using defaut values'
    192           IF (planet_type=='earth') THEN
    193             nqtrue=4 ! Default value for Earth
    194           ELSE
    195             nqtrue=1 ! Default value for other planets
    196           ENDIF
    197        ENDIF
    198 !jyg<
    199 !!       if ( planet_type=='earth') then
    200 !!         ! For Earth, water vapour & liquid tracers are not in the physics
    201 !!         nbtr=nqtrue-2
    202 !!       else
    203 !!         ! Other planets (for now); we have the same number of tracers
    204 !!         ! in the dynamics than in the physics
    205 !!         nbtr=nqtrue
    206 !!       endif
    207 !>jyg
    208     ELSE ! type_trac=inca
    209 !jyg<
    210        ! The traceur.def file is used to define the number "nqo" of water phases
    211        ! present in the simulation. Default : nqo = 2.
    212        OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
    213        IF(ierr.EQ.0) THEN
    214           WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
    215           READ(90,*) nqo
    216        ELSE
    217           WRITE(lunout,*) trim(modname),': Using default value for nqo'
    218           nqo=2
    219        ENDIF
    220        IF (nqo /= 2 .AND. nqo /= 3 ) THEN
    221           WRITE(lunout,*) trim(modname),': nqo=',nqo, ' is not allowded. Only 2 or 3 water phases allowed'
    222           CALL abort_gcm('infotrac_init','Bad number of water phases',1)
    223        END IF
    224        ! nbtr has been read from INCA by init_const_lmdz() in gcm.F
     243        CALL abort_gcm(modname, 'You must add cpp key StratAer and compile with StratAer code',1)
     244#endif
     245    END SELECT
     246  END DO
     247
     248  !--- Disable "config_inca" option for a run without INCA if it differs from "none"
     249  IF (ALL(str(:) /= 'inca') .AND. config_inca /= 'none') THEN
     250    CALL msg('setting config_inca="none" as you do not couple with INCA model')
     251    config_inca = 'none'
     252  END IF
     253
     254!------------------------------------------------------------------------------------------------------------------------------
     255! 1) Get the numbers of: true tracers "nqtrue", water tracers "nqo" (vapor/liquid/solid)
     256!    (here, "true" tracers means declared tracers, first order only)
     257!    Deal with the advection scheme choice for water and tracers:
     258!     iadv = 1    "LMDZ-specific humidity transport" (for H2O vapour)          LMV
     259!     iadv = 2    backward                           (for H2O liquid)          BAK
     260!     iadv = 14   Van-Leer + specific humidity, modified by Francis Codron     VLH
     261!     iadv = 10   Van-Leer (chosen for vapour and liquid water)                VL1
     262!     iadv = 11   Van-Leer for hadv and PPM version (Monotonic) for vadv       VLP
     263!     iadv = 12   Frederic Hourdin I                                           FH1
     264!     iadv = 13   Frederic Hourdin II                                          FH2
     265!     iadv = 16   Monotonic         PPM (Collela & Woodward 1984)              PPM
     266!     iadv = 17   Semi-monotonic    PPM (overshoots allowed)                   PPS
     267!     iadv = 18   Definite positive PPM (overshoots and undershoots allowed)   PPP
     268!     iadv = 20   Slopes                                                       SLP
     269!     iadv = 30   Prather                                                      PRA
     270!
     271!        In array q(ij,l,iq) : iq = 1          for vapour water
     272!                              iq = 2          for liquid water
     273!                             [iq = 3          for ice    water]
     274!        And optionaly:        iq = 3[4],nqtot for other tracers
     275!------------------------------------------------------------------------------------------------------------------------------
     276!    Get choice of advection scheme from file tracer.def or from INCA
     277!------------------------------------------------------------------------------------------------------------------------------
     278
     279  IF(readTracersFiles(type_trac, fType, tracers)) CALL abort_gcm(modname,'problem with tracers file(s)',1)
     280  CALL msg(fType == 0, 'WARNING: USING DEFAULT VALUES !')
     281
     282  !----------------------------------------------------------------------------------------------------------------------------
     283  SELECT CASE(fType)
     284  !----------------------------------------------------------------------------------------------------------------------------
     285    CASE(0)                                                          !=== NO READABLE TRACERS CONFIG FILE => DEFAULT
     286    !--------------------------------------------------------------------------------------------------------------------------
     287      IF(planet_type=='earth') THEN                                  !--- Default for Earth
     288        nqo = 2; nbtr = 2
     289        tracers(:)%name = ['H2O-g','H2O-l','RN   ','PB   ']
     290        tracers(:)%prnt = [tran0  ,tran0  ,tran0  ,tran0  ]
     291        tracers(:)%igen = [1      ,1      ,1      ,1      ]
     292        hadv            = [14     ,10     ,10     ,10     ]
     293        vadv            = [14     ,10     ,10     ,10     ]
     294      ELSE                                                           !--- Default for other planets
     295        nqo = 0; nbtr = 1
     296        tracers(:)%name = ['dummy']
     297        tracers(:)%prnt = ['dummy']
     298        tracers(:)%igen = [1      ]
     299        hadv            = [10     ]
     300        vadv            = [10     ]
     301      END IF
     302      nqtrue = nbtr + nqo
     303    !--------------------------------------------------------------------------------------------------------------------------
     304    CASE(1)
     305    !--------------------------------------------------------------------------------------------------------------------------
     306      IF(type_trac=='inca') THEN                                     !=== OLD STYLE "traceur.def" FOR INCA FOUND
     307      !------------------------------------------------------------------------------------------------------------------------
     308        nqo = SIZE(tracers(:), DIM=1)
     309        WRITE(msg1,'(a,i0)')'Only 2 or 3 water phases allowed ; found nqo=',nqo
     310        IF(nqo/=2 .AND. nqo/=3) CALL abort_gcm(modname,TRIM(msg1),1)
    225311#ifdef INCA
    226        CALL Init_chem_inca_trac(nbtr)
    227 #endif       
    228        nqtrue=nbtr+nqo
    229 
    230        ALLOCATE(hadv_inca(nbtr), vadv_inca(nbtr))
    231 
    232     ENDIF   ! type_trac
    233 !>jyg
    234 
    235     IF ((planet_type=="earth").and.(nqtrue < 2)) THEN
    236        WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum'
    237        CALL abort_gcm('infotrac_init','Not enough tracers',1)
    238     END IF
    239    
    240 !jyg<
    241 ! Transfert number of tracers to Reprobus
    242 !!    IF (type_trac == 'repr') THEN
    243 !!#ifdef REPROBUS
    244 !!       CALL Init_chem_rep_trac(nbtr)
    245 !!#endif
    246 !!    END IF
    247 !>jyg
    248        
    249 !
    250 ! Allocate variables depending on nqtrue
    251 !
    252     ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue),tnom_transp(nqtrue))
    253 
    254 !
    255 !jyg<
    256 !!    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
    257 !!    conv_flg(:) = 1 ! convection activated for all tracers
    258 !!    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
    259 !>jyg
    260 
    261 !-----------------------------------------------------------------------
    262 ! 2)     Choix  des schemas d'advection pour l'eau et les traceurs
    263 !
    264 !     iadv = 1    schema  transport type "humidite specifique LMD"
    265 !     iadv = 2    schema   amont
    266 !     iadv = 14   schema  Van-leer + humidite specifique
    267 !                            Modif F.Codron
    268 !     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
    269 !     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
    270 !     iadv = 12   schema  Frederic Hourdin I
    271 !     iadv = 13   schema  Frederic Hourdin II
    272 !     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
    273 !     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
    274 !     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
    275 !     iadv = 20   schema  Slopes
    276 !     iadv = 30   schema  Prather
    277 !
    278 !        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
    279 !                                     iq = 2  pour l'eau liquide
    280 !       Et eventuellement             iq = 3,nqtot pour les autres traceurs
    281 !
    282 !        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
    283 !------------------------------------------------------------------------
    284 !
    285 !    Get choice of advection schema from file tracer.def or from INCA
    286 !---------------------------------------------------------------------
    287     IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag' .OR. type_trac == 'co2i') THEN
    288        IF(ierr.EQ.0) THEN
    289           ! Continue to read tracer.def
    290           DO iq=1,nqtrue
    291 
    292              write(*,*) 'infotrac 237: iq=',iq
    293              ! CRisi: ajout du nom du fluide transporteur
    294              ! mais rester retro compatible
    295              READ(90,'(I2,X,I2,X,A)',IOSTAT=IOstatus) hadv(iq),vadv(iq),tchaine
    296              write(lunout,*) 'iq,hadv(iq),vadv(iq)=',iq,hadv(iq),vadv(iq)
    297              write(lunout,*) 'tchaine=',trim(tchaine)
    298              write(*,*) 'infotrac 238: IOstatus=',IOstatus
    299              if (IOstatus.ne.0) then
    300                 CALL abort_gcm('infotrac_init','Pb dans la lecture de traceur.def',1)
    301              endif
    302              ! Y-a-t-il 1 ou 2 noms de traceurs? -> On regarde s'il y a un
    303              ! espace ou pas au milieu de la chaine.
    304              continu=.true.
    305              nouveau_traceurdef=.false.
    306              iiq=1
    307              do while (continu)
    308                 if (tchaine(iiq:iiq).eq.' ') then
    309                   nouveau_traceurdef=.true.
    310                   continu=.false.
    311                 else if (iiq.lt.LEN_TRIM(tchaine)) then
    312                   iiq=iiq+1
    313                 else
    314                   continu=.false.
    315                 endif
    316              enddo
    317              write(*,*) 'iiq,nouveau_traceurdef=',iiq,nouveau_traceurdef
    318              if (nouveau_traceurdef) then
    319                 write(lunout,*) 'C''est la nouvelle version de traceur.def'
    320                 tnom_0(iq)=tchaine(1:iiq-1)
    321                 tnom_transp(iq)=tchaine(iiq+1:15)
    322              else
    323                 write(lunout,*) 'C''est l''ancienne version de traceur.def'
    324                 write(lunout,*) 'On suppose que les traceurs sont tous d''air'
    325                 tnom_0(iq)=tchaine
    326                 tnom_transp(iq) = 'air'
    327              endif
    328              write(lunout,*) 'tnom_0(iq)=<',trim(tnom_0(iq)),'>'
    329              write(lunout,*) 'tnom_transp(iq)=<',trim(tnom_transp(iq)),'>'
    330 
    331           END DO !DO iq=1,nqtrue
    332           CLOSE(90) 
    333 
    334        ELSE ! Without tracer.def, set default values
    335          if (planet_type=="earth") then
    336           ! for Earth, default is to have 4 tracers
    337           hadv(1) = 14
    338           vadv(1) = 14
    339           tnom_0(1) = 'H2Ov'
    340           tnom_transp(1) = 'air'
    341           hadv(2) = 10
    342           vadv(2) = 10
    343           tnom_0(2) = 'H2Ol'
    344           tnom_transp(2) = 'air'
    345           hadv(3) = 10
    346           vadv(3) = 10
    347           tnom_0(3) = 'RN'
    348           tnom_transp(3) = 'air'
    349           hadv(4) = 10
    350           vadv(4) = 10
    351           tnom_0(4) = 'PB'
    352           tnom_transp(4) = 'air'
    353          else ! default for other planets
    354           hadv(1) = 10
    355           vadv(1) = 10
    356           tnom_0(1) = 'dummy'
    357           tnom_transp(1) = 'dummy'
    358          endif ! of if (planet_type=="earth")
    359        END IF
    360        
    361        WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
    362        WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
    363        DO iq=1,nqtrue
    364           WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq),tnom_transp(iq)
    365        END DO
    366 
    367        IF ( planet_type=='earth') THEN
    368          !CR: nombre de traceurs de l eau
    369          IF (tnom_0(3) == 'H2Oi') THEN
    370             nqo=3
    371          ELSE
    372             nqo=2
    373          ENDIF
    374          ! For Earth, water vapour & liquid tracers are not in the physics
    375          nbtr=nqtrue-nqo
    376        ELSE
    377          ! Other planets (for now); we have the same number of tracers
    378          ! in the dynamics than in the physics
    379          nbtr=nqtrue
    380        ENDIF
     312        CALL Init_chem_inca_trac(nbtr)                                   !--- Get nbtr from INCA
     313#endif
     314        ALLOCATE(hadv_inca(nbtr), vadv_inca(nbtr), conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
     315#ifdef INCA
     316        !--- Activation of:                      Convection, Boundary layer
     317        CALL init_transport(hadv_inca, vadv_inca, conv_flg,   pbl_flg,   solsym)
     318#endif
     319        nqtrue = nbtr + nqo                                              !--- Total number of tracers
     320        ALLOCATE(ttr(nqtrue)); ttr(1:nqo) = tracers(1:nqo)
     321        DO iq = nqo+1, nqtrue
     322          ttr(iq)%name = solsym(iq)
     323          ttr(iq)%prnt = tran0
     324          ttr(iq)%igen = 1
     325          hadv = hadv_inca(iq-nqo)
     326          vadv = vadv_inca(iq-nqo)
     327        END DO
     328        CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
     329      !------------------------------------------------------------------------------------------------------------------------
     330      ELSE                                                           !=== OLD STYLE "traceur.def" CONFIG FILE FOUND
     331      !------------------------------------------------------------------------------------------------------------------------
     332        nqo = 0
     333        DO ip = 1, SIZE(oldH2O)
     334          ix = strIdx(tracers(:)%name,oldH2O(ip))                    !--- Old name of water in a specific phase (ix/=0)
     335          IF(ix == 0) CYCLE
     336          newH2O = 'H2O-'//known_phases(ip:ip)                       !--- Corresponding new name
     337          nqo = nqo+1; tracers(ix)%name = newH2O                     !--- One more water phase ; replace old name with one
     338          tracers(strFind(tracers(:)%nam1,oldH2O(ip)))%nam1 = newH2O
     339          tracers(strFind(tracers(:)%prnt,oldH2O(ip)))%prnt = newH2O
     340        END DO
     341        nqtrue = SIZE(tracers,DIM=1)
     342        nbtr   = nqtrue - nqo
     343      END IF
     344    !--------------------------------------------------------------------------------------------------------------------------
     345    CASE DEFAULT                                                     !=== FOUND NEW STYLE TRACERS CONFIG FILE(S)
     346    !--------------------------------------------------------------------------------------------------------------------------
     347      nqo    = 2; IF(ANY(tracers(:)%name == 'H2O-s')) nqo=3
     348      nqtrue = SIZE(tracers, DIM=1)
     349      nbtr   = nqtrue - nqo
     350  !----------------------------------------------------------------------------------------------------------------------------
     351  END SELECT
     352  !----------------------------------------------------------------------------------------------------------------------------
     353  CALL getKey_init(tracers)
     354  IF(.NOT.ALLOCATED(hadv)) lerr = getKey('hadv', hadv)
     355  IF(.NOT.ALLOCATED(vadv)) lerr = getKey('vadv', vadv)
     356  IF(.NOT.ALLOCATED(solsym)) ALLOCATE(solsym(nbtr))
     357  IF(.NOT.ALLOCATED(conv_flg)) conv_flg = [(1, it=1, nbtr)]
     358  IF(.NOT.ALLOCATED( pbl_flg))  pbl_flg = [(1, it=1, nbtr)]
    381359
    382360#ifdef CPP_StratAer
    383        IF (type_trac == 'coag') THEN
    384          nbtr_bin=0
    385          nbtr_sulgas=0
    386          DO iq=1,nqtrue
    387            IF (tnom_0(iq)(1:3)=='BIN') THEN !check if tracer name contains 'BIN'
    388              nbtr_bin=nbtr_bin+1
    389            ENDIF
    390            IF (tnom_0(iq)(1:3)=='GAS') THEN !check if tracer name contains 'GAS'
    391              nbtr_sulgas=nbtr_sulgas+1
    392            ENDIF
    393          ENDDO
    394          print*,'nbtr_bin=',nbtr_bin
    395          print*,'nbtr_sulgas=',nbtr_sulgas
    396          DO iq=1,nqtrue
    397            IF (tnom_0(iq)=='GASOCS') THEN
    398              id_OCS_strat=iq-nqo
    399            ENDIF
    400            IF (tnom_0(iq)=='GASSO2') THEN
    401              id_SO2_strat=iq-nqo
    402            ENDIF
    403            IF (tnom_0(iq)=='GASH2SO4') THEN
    404              id_H2SO4_strat=iq-nqo
    405            ENDIF
    406            IF (tnom_0(iq)=='BIN01') THEN
    407              id_BIN01_strat=iq-nqo
    408            ENDIF
    409            IF (tnom_0(iq)=='GASTEST') THEN
    410              id_TEST_strat=iq-nqo
    411            ENDIF
    412          ENDDO
    413          print*,'id_OCS_strat  =',id_OCS_strat
    414          print*,'id_SO2_strat  =',id_SO2_strat
    415          print*,'id_H2SO4_strat=',id_H2SO4_strat
    416          print*,'id_BIN01_strat=',id_BIN01_strat
    417        ENDIF
    418 #endif
    419 
    420     ENDIF  ! (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac = 'coag')
    421 !jyg<
    422 !
    423 ! Transfert number of tracers to Reprobus
    424     IF (type_trac == 'repr') THEN
     361  IF (type_trac == 'coag') THEN
     362    nbtr_bin=0
     363    nbtr_sulgas=0
     364    DO iq = 1, nqtrue
     365      IF(tracers(iq)%name(1:3)=='BIN') nbtr_bin    = nbtr_bin   +1
     366      IF(tracers(iq)%name(1:3)=='GAS') nbtr_sulgas = nbtr_sulgas+1
     367      SELECT CASE(tracers(iq)%name)
     368        CASE('BIN01');    id_BIN01_strat = iq - nqo; CALL msg('id_BIN01_strat=', id_BIN01_strat)
     369        CASE('GASOCS');   id_OCS_strat   = iq - nqo; CALL msg('id_OCS_strat  =', id_OCS_strat)
     370        CASE('GASSO2');   id_SO2_strat   = iq - nqo; CALL msg('id_SO2_strat  =', id_SO2_strat)
     371        CASE('GASH2SO4'); id_H2SO4_strat = iq - nqo; CALL msg('id_H2SO4_strat=', id_H2SO4_strat)
     372        CASE('GASTEST');  id_TEST_strat  = iq - nqo; CALL msg('id_TEST_strat=' , id_TEST_strat)
     373      END SELECT
     374    END DO
     375    CALL msg('nbtr_bin      =',nbtr_bin)
     376    CALL msg('nbtr_sulgas   =',nbtr_sulgas)
     377  END IF
     378#endif
     379
     380  !--- Transfert number of tracers to Reprobus
    425381#ifdef REPROBUS
    426        CALL Init_chem_rep_trac(nbtr,nqo,tnom_0)
    427 #endif
    428     END IF
    429 !
    430 ! Allocate variables depending on nbtr
    431 !
    432     ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
    433     conv_flg(:) = 1 ! convection activated for all tracers
    434     pbl_flg(:)  = 1 ! boundary layer activated for all tracers
    435 !
    436 !!    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
    437 !
    438     IF (type_trac == 'inca') THEN   ! config_inca='aero' ou 'chem'
    439 !>jyg
    440 ! le module de chimie fournit les noms des traceurs
    441 ! et les schemas d'advection associes. excepte pour ceux lus
    442 ! dans traceur.def
    443        IF (ierr .eq. 0) then
    444           DO iq=1,nqo
    445 
    446              write(*,*) 'infotrac 237: iq=',iq
    447              ! CRisi: ajout du nom du fluide transporteur
    448              ! mais rester retro compatible
    449              READ(90,'(I2,X,I2,X,A)',IOSTAT=IOstatus) hadv(iq),vadv(iq),tchaine
    450              write(lunout,*) 'iq,hadv(iq),vadv(iq)=',iq,hadv(iq),vadv(iq)
    451              write(lunout,*) 'tchaine=',trim(tchaine)
    452              write(*,*) 'infotrac 238: IOstatus=',IOstatus
    453              if (IOstatus.ne.0) then
    454                 CALL abort_gcm('infotrac_init','Pb dans la lecture de traceur.def',1)
    455              endif
    456              ! Y-a-t-il 1 ou 2 noms de traceurs? -> On regarde s'il y a un
    457              ! espace ou pas au milieu de la chaine.
    458              continu=.true.
    459              nouveau_traceurdef=.false.
    460              iiq=1
    461              do while (continu)
    462                 if (tchaine(iiq:iiq).eq.' ') then
    463                   nouveau_traceurdef=.true.
    464                   continu=.false.
    465                 else if (iiq.lt.LEN_TRIM(tchaine)) then
    466                   iiq=iiq+1
    467                 else
    468                   continu=.false.
    469                 endif
    470              enddo
    471              write(*,*) 'iiq,nouveau_traceurdef=',iiq,nouveau_traceurdef
    472              if (nouveau_traceurdef) then
    473                 write(lunout,*) 'C''est la nouvelle version de traceur.def'
    474                 tnom_0(iq)=tchaine(1:iiq-1)
    475                 tnom_transp(iq)=tchaine(iiq+1:15)
    476              else
    477                 write(lunout,*) 'C''est l''ancienne version de traceur.def'
    478                 write(lunout,*) 'On suppose que les traceurs sont tous d''air'
    479                 tnom_0(iq)=tchaine
    480                 tnom_transp(iq) = 'air'
    481              endif
    482              write(lunout,*) 'tnom_0(iq)=<',trim(tnom_0(iq)),'>'
    483              write(lunout,*) 'tnom_transp(iq)=<',trim(tnom_transp(iq)),'>'
    484 
    485           END DO !DO iq=1,nqtrue
    486           CLOSE(90) 
    487        ELSE  !! if traceur.def doesn't exist
    488           tnom_0(1)='H2Ov'
    489           tnom_transp(1) = 'air'
    490           tnom_0(2)='H2Ol'
    491           tnom_transp(2) = 'air'
    492           hadv(1) = 10
    493           hadv(2) = 10
    494           vadv(1) = 10
    495           vadv(2) = 10
    496        ENDIF
    497  
    498 #ifdef INCA
    499        CALL init_transport( &
    500             hadv_inca, &
    501             vadv_inca, &
    502             conv_flg, &
    503             pbl_flg,  &
    504             solsym)
    505 #endif
    506 
    507 
    508 !jyg<
    509        DO iq = nqo+1, nqtrue
    510           hadv(iq) = hadv_inca(iq-nqo)
    511           vadv(iq) = vadv_inca(iq-nqo)
    512           tnom_0(iq)=solsym(iq-nqo)
    513           tnom_transp(iq) = 'air'
    514        END DO
    515 
    516     END IF ! (type_trac == 'inca')
    517 
    518 !-----------------------------------------------------------------------
    519 !
    520 ! 3) Verify if advection schema 20 or 30 choosen
     382  IF(type_trac == 'repr') CALL Init_chem_rep_trac(nbtr,nqo,tracers(:)%name)
     383#endif
     384
     385!------------------------------------------------------------------------------------------------------------------------------
     386! 2) Verify if the advection scheme 20 or 30 have been chosen.
    521387!    Calculate total number of tracers needed: nqtot
    522388!    Allocate variables depending on total number of tracers
    523 !-----------------------------------------------------------------------
    524     new_iq=0
    525     DO iq=1,nqtrue
    526        ! Add tracers for certain advection schema
    527        IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN
    528           new_iq=new_iq+1  ! no tracers added
    529        ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN
    530           new_iq=new_iq+4  ! 3 tracers added
    531        ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN
    532           new_iq=new_iq+10 ! 9 tracers added
    533        ELSE
    534           WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
    535           CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1)
    536        END IF
     389!------------------------------------------------------------------------------------------------------------------------------
     390  DO iq = 1, nqtrue
     391    t1 => tracers(iq)
     392    IF( hadv(iq)<20 .OR. (ANY(hadv(iq)==[20,30]) .AND. hadv(iq)==vadv(iq)) ) CYCLE
     393    WRITE(msg1,'(2(a,i0))')' is not available: hadv=',hadv(iq),', vadv=',vadv(iq)
     394    CALL msg('This choice of advection scheme for "'//TRIM(t1%name)//'"'//TRIM(msg1))
     395    CALL abort_gcm(modname,'Bad choice of advection scheme',1)
     396  END DO
     397  nqtot =    COUNT( hadv< 20 .AND. vadv< 20 ) &                      !--- No additional tracer
     398        +  4*COUNT( hadv==20 .AND. vadv==20 ) &                      !--- 3  additional tracers
     399        + 10*COUNT( hadv==30 .AND. vadv==30 )                        !--- 9  additional tracers
     400
     401  ! More tracers due to the choice of advection scheme => assign total number of tracers
     402  IF( nqtot /= nqtrue ) THEN
     403    CALL msg('The choice of advection scheme for one or more tracers makes it necessary to add tracers')
     404    CALL msg('The number of true tracers is '//TRIM(int2str(nqtrue)))
     405    CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot)))
     406  END IF
     407  ALLOCATE(ttr(nqtot))
     408
     409!------------------------------------------------------------------------------------------------------------------------------
     410! 3) Determine iadv, long and short name, generation number, phase and region
     411!------------------------------------------------------------------------------------------------------------------------------
     412  jq = 0; ttr(:)%iadv = -1
     413  DO iq = 1, nqtrue
     414    jq = jq + 1
     415    t1 => tracers(iq)
     416
     417    !--- Verify choice of advection schema
     418    iad = -1
     419    IF(hadv(iq)     ==    vadv(iq)    ) iad = hadv(iq)
     420    IF(hadv(iq)==10 .AND. vadv(iq)==16) iad = 11
     421    CALL msg(iad == -1, 'This choice of advection scheme for "'//TRIM(t1%name)//'" '//'is not available: hadv = ' &
     422                            //TRIM(int2str(hadv(iq)))//', vadv='//TRIM(int2str(vadv(iq))) )
     423    IF(iad == -1) CALL abort_gcm(modname,'Bad choice of advection scheme - 2',1)
     424    t1%lnam = t1%name; IF(iad /= 0) t1%lnam=TRIM(t1%name)//descrq(iad)
     425
     426    !--- Defining most fields of the tracer derived type
     427    ttr(jq)%name = t1%name
     428    ttr(jq)%nam1 = t1%nam1
     429    ttr(jq)%prnt = t1%prnt
     430    ttr(jq)%lnam = t1%lnam
     431    ttr(jq)%type = t1%type
     432    ttr(jq)%phas = t1%phas
     433    ttr(jq)%iadv = iad
     434    ttr(jq)%igen = t1%igen
     435
     436    IF(ALL([20,30] /= iad)) CYCLE                                    !--- 1st order scheme: finished
     437    IF(iad == 20) nm = 3                                             !--- 2nd order scheme
     438    IF(iad == 30) nm = 9                                             !--- 3rd order scheme
     439    ttr(jq+1:jq+nm)%name = [ (TRIM(t1%name)//'-'//TRIM(suff(im)), im=1, nm) ]
     440    ttr(jq+1:jq+nm)%nam1 = [ (TRIM(t1%nam1)//'-'//TRIM(suff(im)), im=1, nm) ]
     441    ttr(jq+1:jq+nm)%lnam = [ (TRIM(t1%lnam)//'-'//TRIM(suff(im)), im=1, nm) ]
     442    ttr(jq+1:jq+nm)%prnt = t1%prnt
     443    ttr(jq+1:jq+nm)%type = t1%type
     444    ttr(jq+1:jq+nm)%phas = t1%phas
     445    ttr(jq+1:jq+nm)%iadv = -iad
     446    ttr(jq+1:jq+nm)%igen = t1%igen
     447    jq = jq + nm
     448  END DO
     449  DEALLOCATE(hadv, vadv)
     450
     451  !--- Determine parent and childs indexes
     452  CALL indexUpdate(ttr)
     453
     454  !=== TEST ADVECTION SCHEME
     455  DO iq=1,nqtot ; t1 => ttr(iq); iad = t1%iadv
     456    WRITE(msg1,'(a,i0)')'This LMDZ version has not been tested for option iadv=',iad
     457    WRITE(msg2,'(a,i2,a)')'iadv=',iad,' not implemented yet for'
     458
     459    !--- ONLY TESTED VALUES FOR TRACERS FOR NOW: iadv = 14, 10 (and 0)
     460    IF(ALL( [10,14,0] /= iad) ) CALL abort_gcm(modname, TRIM(msg1)//' ; only iadv=10 and iadv=14 are tested !', 1)
     461
     462    !--- ONLY TESTED VALUES FOR CHILDS  FOR NOW: iadv = 10     (CHILDS:  TRACERS OF GENERATION GREATER THAN 1)
     463    IF(fmsg(iad/=10.AND.t1%igen>1,'WARNING ! '//TRIM(msg2)//' childs.  Setting iadv=10 for "'//TRIM(t1%name)//'".')) t1%iadv=10
     464
     465    !--- ONLY TESTED VALUES FOR PARENTS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1)
     466    IF(t1%igen==1 .AND. ALL([10,14]/=iad)) CALL abort_gcm(modname, TRIM(msg2)//' parents: schemes 10 or 14 only !', 1)
     467
     468    !--- iadv = 14 IS ONLY VALID FOR WATER VAPOUR
     469    IF(fmsg(iad==14 .AND. t1%name(1:5)/='H2O-g', 'WARNING ! '//TRIM(msg1)//', found for "' &
     470                 //TRIM(t1%name)//'" but only valid for water vapour ! Setting iadv=10 for "'//TRIM(t1%name)//'".')) t1%iadv=10
     471  END DO
     472
     473  !=== DISPLAY THE RESULTING LIST
     474  CALL msg('Information stored in infotrac :')
     475  IF(dispTable('isssiii', ['iq       ','name     ','long name','parent   ','iadv     ','ipar     ','igen     '],       &
     476       cat(ttr(:)%name, ttr(:)%lnam, ttr(:)%prnt), cat([(iq, iq=1, nqtot)], ttr(:)%iadv, ttr(:)%iprnt, ttr(:)%igen))) &
     477       CALL abort_gcm(modname,"problem with the tracers table content",1)
     478
     479  CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
     480  t => tracers
     481
     482  !=== VARIABLES RELATED TO GENERATIONS
     483  niadv = PACK( [(iq,iq=1,nqtot)], MASK=t(:)%iadv>=0)           !--- Indexes of "true" tracers
     484
     485  p = PACK(delPhase(t%prnt),MASK=t%type=='tracer'.AND.t%igen==2)!--- Parents of 2nd generation isotopes
     486  CALL strReduce(p, nbIso)
     487  ALLOCATE(isotopes(nbIso))
     488
     489  IF(nbIso==0) RETURN                                           !=== NO ISOTOPES: FINISHED
     490
     491  CALL msg('Isotopes families required: '//strStack(p))
     492
     493  !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES
     494  isotopes(:)%prnt = p
     495  DO ip = 1, SIZE(p)                                            !--- Loop on isotopes categories
     496    s => isotopes(ip)
     497    iname = s%prnt
     498
     499    !=== Geographic tagging tracers descending on tracer "iname": mask, names, number
     500    lisoZone = t(:)%type=='tag'    .AND. delPhase(t(:)%nam1) == iname .AND. t(:)%igen == 3
     501    s%zone = PACK(strTail(t(:)%name,'_'), MASK = lisoZone)      !--- Tagging zones names  for isotopes category "iname"
     502    CALL strReduce(s%zone)
     503    s%nzon = SIZE(s%zone)                                       !--- Tagging zones number for isotopes category "iname"
     504
     505    !=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname")
     506    lisoName = t(:)%type=='tracer' .AND. delPhase(t(:)%prnt) == iname .AND. t(:)%phas == 'g'
     507    ALLOCATE(s%keys(COUNT(lisoName)))
     508    s%keys(:)%name = PACK(delPhase(t(:)%name), MASK = lisoName)    !--- Effectively found isotopes of "iname"
     509    s%niso = SIZE(s%keys)                                       !--- Number of "effectively found isotopes of "iname"
     510    s%trac = [s%keys%name, ((TRIM(s%keys(it)%name)//'_'//TRIM(s%zone(iz)), it=1, s%niso), iz=1, s%nzon)]
     511    s%nitr = SIZE(s%trac)                                       !--- " + their geographic tracers               [ntraciso]
     512
     513    !=== Phases for tracer "iname"
     514    s%phas = ''
     515    DO ix = 1, nphases; IF(strIdx(t%name,addPhase(iname, known_phases(ix:ix))) /= 0) s%phas = TRIM(s%phas)//ph; END DO
     516    s%npha = LEN_TRIM(s%phas)                                   !--- Equal to "nqo" for water
     517
     518    !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot)
     519    DO iq = 1, nqtot
     520      t1 => tracers(iq)
     521      IF(t1%nam1 /= iname) CYCLE                                 !--- Only deal with tracers descending on "iname"
     522      t1%iso_igr = ip                                            !--- Index of isotopes family in list "isotopes(:)%prnt"
     523      t1%iso_num = strIdx(s%trac, delPhase(strHead(t1%name,'_')))!--- Index of current isotope       in effective isotopes list
     524      t1%iso_zon = strIdx(s%zone,          strTail(t1%name,'_') )!--- Index of current isotope zone  in effective zones    list
     525      t1%iso_pha =  INDEX(s%phas,TRIM(t1%phas))                  !--- Index of current isotope phase in effective phases   list
     526      IF(t1%igen /= 3) t1%iso_zon = 0                            !--- Skip possible generation 2 tagging tracers
    537527    END DO
    538    
    539     IF (new_iq /= nqtrue) THEN
    540        ! The choice of advection schema imposes more tracers
    541        ! Assigne total number of tracers
    542        nqtot = new_iq
    543 
    544        WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers'
    545        WRITE(lunout,*) 'makes it necessary to add tracers'
    546        WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers'
    547        WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed'
    548 
    549     ELSE
    550        ! The true number of tracers is also the total number
    551        nqtot = nqtrue
    552     END IF
    553 
    554 !
    555 ! Allocate variables with total number of tracers, nqtot
    556 !
    557     ALLOCATE(tname(nqtot), ttext(nqtot))
    558     ALLOCATE(iadv(nqtot), niadv(nqtot))
    559 
    560 !-----------------------------------------------------------------------
    561 !
    562 ! 4) Determine iadv, long and short name
    563 !
    564 !-----------------------------------------------------------------------
    565     new_iq=0
    566     DO iq=1,nqtrue
    567        new_iq=new_iq+1
    568 
    569        ! Verify choice of advection schema
    570        IF (hadv(iq)==vadv(iq)) THEN
    571           iadv(new_iq)=hadv(iq)
    572        ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN
    573           iadv(new_iq)=11
    574        ELSE
    575           WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
    576 
    577           CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1)
    578        END IF
    579      
    580        str1=tnom_0(iq)
    581        tname(new_iq)= tnom_0(iq)
    582        IF (iadv(new_iq)==0) THEN
    583           ttext(new_iq)=trim(str1)
    584        ELSE
    585           ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq))
    586        END IF
    587 
    588        ! schemas tenant compte des moments d'ordre superieur
    589        str2=ttext(new_iq)
    590        IF (iadv(new_iq)==20) THEN
    591           DO jq=1,3
    592              new_iq=new_iq+1
    593              iadv(new_iq)=-20
    594              ttext(new_iq)=trim(str2)//txts(jq)
    595              tname(new_iq)=trim(str1)//txts(jq)
    596           END DO
    597        ELSE IF (iadv(new_iq)==30) THEN
    598           DO jq=1,9
    599              new_iq=new_iq+1
    600              iadv(new_iq)=-30
    601              ttext(new_iq)=trim(str2)//txtp(jq)
    602              tname(new_iq)=trim(str1)//txtp(jq)
    603           END DO
    604        END IF
    605     END DO
    606 
    607 !
    608 ! Find vector keeping the correspodence between true and total tracers
    609 !
    610     niadv(:)=0
    611     iiq=0
    612     DO iq=1,nqtot
    613        IF(iadv(iq).GE.0) THEN
    614           ! True tracer
    615           iiq=iiq+1
    616           niadv(iiq)=iq
    617        ENDIF
    618     END DO
    619 
    620 
    621     WRITE(lunout,*) trim(modname),': Information stored in infotrac :'
    622     WRITE(lunout,*) trim(modname),': iadv  niadv tname  ttext :'
    623     DO iq=1,nqtot
    624        WRITE(lunout,*) iadv(iq),niadv(iq),&
    625        ' ',trim(tname(iq)),' ',trim(ttext(iq))
    626     END DO
    627 
    628 !
    629 ! Test for advection schema.
    630 ! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) .
    631 !
    632     DO iq=1,nqtot
    633        IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN
    634           WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
    635           CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1)
    636        ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN
    637           WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
    638           CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1)
    639        END IF
    640     END DO
    641 
    642 
    643 ! CRisi: quels sont les traceurs fils et les traceurs pères.
    644 ! initialiser tous les tableaux d'indices liés aux traceurs familiaux
    645 ! + vérifier que tous les pères sont écrits en premières positions
    646     ALLOCATE(nqfils(nqtot),nqdesc(nqtot))   
    647     ALLOCATE(iqfils(nqtot,nqtot))   
    648     ALLOCATE(iqpere(nqtot))
    649     nqperes=0
    650     nqfils(:)=0
    651     nqdesc(:)=0
    652     iqfils(:,:)=0
    653     iqpere(:)=0
    654     nqdesc_tot=0   
    655     DO iq=1,nqtot
    656       if (tnom_transp(iq) == 'air') then
    657         ! ceci est un traceur père
    658         WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un pere'
    659         nqperes=nqperes+1
    660         iqpere(iq)=0
    661       else !if (tnom_transp(iq) == 'air') then
    662         ! ceci est un fils. Qui est son père?
    663         WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un fils'
    664         continu=.true.
    665         ipere=1
    666         do while (continu)           
    667           if (tnom_transp(iq) == tnom_0(ipere)) then
    668             ! Son père est ipere
    669             WRITE(lunout,*) 'Le traceur',iq,'appele ', &
    670       &          trim(tnom_0(iq)),' est le fils de ',ipere,'appele ',trim(tnom_0(ipere))
    671             nqfils(ipere)=nqfils(ipere)+1 
    672             iqfils(nqfils(ipere),ipere)=iq
    673             iqpere(iq)=ipere         
    674             continu=.false.
    675           else !if (tnom_transp(iq) == tnom_0(ipere)) then
    676             ipere=ipere+1
    677             if (ipere.gt.nqtot) then
    678                 WRITE(lunout,*) 'Le traceur',iq,'appele ', &
    679       &          trim(tnom_0(iq)),', est orphelin.'
    680                 CALL abort_gcm('infotrac_init','Un traceur est orphelin',1)
    681             endif !if (ipere.gt.nqtot) then
    682           endif !if (tnom_transp(iq) == tnom_0(ipere)) then
    683         enddo !do while (continu)
    684       endif !if (tnom_transp(iq) == 'air') then
    685     enddo !DO iq=1,nqtot
    686     WRITE(lunout,*) 'infotrac: nqperes=',nqperes   
    687     WRITE(lunout,*) 'nqfils=',nqfils
    688     WRITE(lunout,*) 'iqpere=',iqpere
    689     WRITE(lunout,*) 'iqfils=',iqfils
    690 
    691 ! Calculer le nombre de descendants à partir de iqfils et de nbfils
    692     DO iq=1,nqtot   
    693       generation=0
    694       continu=.true.
    695       ifils=iq
    696       do while (continu)
    697         ipere=iqpere(ifils)
    698         if (ipere.gt.0) then
    699          nqdesc(ipere)=nqdesc(ipere)+1   
    700          nqdesc_tot=nqdesc_tot+1     
    701          iqfils(nqdesc(ipere),ipere)=iq
    702          ifils=ipere
    703          generation=generation+1
    704         else !if (ipere.gt.0) then
    705          continu=.false.
    706         endif !if (ipere.gt.0) then
    707       enddo !do while (continu)   
    708       WRITE(lunout,*) 'Le traceur ',iq,', appele ',trim(tnom_0(iq)),' est un traceur de generation: ',generation
    709     enddo !DO iq=1,nqtot
    710     WRITE(lunout,*) 'infotrac: nqdesc=',nqdesc
    711     WRITE(lunout,*) 'iqfils=',iqfils
    712     WRITE(lunout,*) 'nqdesc_tot=',nqdesc_tot
    713 
    714 ! Interdire autres schémas que 10 pour les traceurs fils, et autres schémas
    715 ! que 10 et 14 si des pères ont des fils
    716     do iq=1,nqtot
    717       if (iqpere(iq).gt.0) then
    718         ! ce traceur a un père qui n'est pas l'air
    719         ! Seul le schéma 10 est autorisé
    720         if (iadv(iq)/=10) then
    721            WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for sons'
    722           CALL abort_gcm('infotrac_init','Sons should be advected by scheme 10',1)
    723         endif
    724         ! Le traceur père ne peut être advecté que par schéma 10 ou 14:
    725         IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
    726           WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for fathers'
    727           CALL abort_gcm('infotrac_init','Fathers should be advected by scheme 10 ou 14',1)
    728         endif !IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
    729      endif !if (iqpere(iq).gt.0) the
    730     enddo !do iq=1,nqtot
    731 
    732     WRITE(lunout,*) 'infotrac init fin'
    733 
    734 ! detecter quels sont les traceurs isotopiques parmi des traceurs
    735     call infotrac_isoinit(tnom_0,nqtrue)
    736        
    737 !-----------------------------------------------------------------------
    738 ! Finalize :
    739 !
    740     DEALLOCATE(tnom_0, hadv, vadv,tnom_transp)
    741 
    742 
    743   END SUBROUTINE infotrac_init
    744 
    745   SUBROUTINE infotrac_isoinit(tnom_0,nqtrue)
    746 
    747 #ifdef CPP_IOIPSL
    748   use IOIPSL
    749 #else
    750   ! if not using IOIPSL, we still need to use (a local version of) getin
    751   use ioipsl_getincom
    752 #endif
    753   implicit none
    754  
    755     ! inputs
    756     INTEGER nqtrue
    757     CHARACTER(len=15) tnom_0(nqtrue)
    758    
    759     ! locals   
    760     CHARACTER(len=3), DIMENSION(niso_possibles) :: tnom_iso
    761     INTEGER, ALLOCATABLE,DIMENSION(:,:) :: nb_iso,nb_traciso
    762     INTEGER, ALLOCATABLE,DIMENSION(:) :: nb_isoind
    763     INTEGER :: ntraceurs_zone_prec,iq,phase,ixt,iiso,izone
    764     CHARACTER(len=19) :: tnom_trac
    765     INCLUDE "iniprint.h"
    766 
    767     tnom_iso=(/'eau','HDO','O18','O17','HTO'/)
    768 
    769     ALLOCATE(nb_iso(niso_possibles,nqo))
    770     ALLOCATE(nb_isoind(nqo))
    771     ALLOCATE(nb_traciso(niso_possibles,nqo))
    772     ALLOCATE(iso_num(nqtot))
    773     ALLOCATE(iso_indnum(nqtot))
    774     ALLOCATE(zone_num(nqtot))
    775     ALLOCATE(phase_num(nqtot))
    776      
    777     iso_num(:)=0
    778     iso_indnum(:)=0
    779     zone_num(:)=0
    780     phase_num(:)=0
    781     indnum_fn_num(:)=0
    782     use_iso(:)=.false. 
    783     nb_iso(:,:)=0 
    784     nb_isoind(:)=0     
    785     nb_traciso(:,:)=0
    786     niso=0
    787     ntraceurs_zone=0 
    788     ntraceurs_zone_prec=0
    789     ntraciso=0
    790 
    791     do iq=nqo+1,nqtot
    792 !       write(lunout,*) 'infotrac 569: iq,tnom_0(iq)=',iq,tnom_0(iq)
    793        do phase=1,nqo   
    794         do ixt= 1,niso_possibles   
    795          tnom_trac=trim(tnom_0(phase))//'_'
    796          tnom_trac=trim(tnom_trac)//trim(tnom_iso(ixt))
    797 !         write(*,*) 'phase,ixt,tnom_trac=',phase,ixt,tnom_trac     
    798          IF (tnom_0(iq) == tnom_trac) then
    799 !          write(lunout,*) 'Ce traceur est un isotope'
    800           nb_iso(ixt,phase)=nb_iso(ixt,phase)+1   
    801           nb_isoind(phase)=nb_isoind(phase)+1   
    802           iso_num(iq)=ixt
    803           iso_indnum(iq)=nb_isoind(phase)
    804           indnum_fn_num(ixt)=iso_indnum(iq)
    805           phase_num(iq)=phase
    806 !          write(lunout,*) 'iso_num(iq)=',iso_num(iq)
    807 !          write(lunout,*) 'iso_indnum(iq)=',iso_indnum(iq)
    808 !          write(lunout,*) 'indnum_fn_num(ixt)=',indnum_fn_num(ixt)
    809 !          write(lunout,*) 'phase_num(iq)=',phase_num(iq)
    810           goto 20
    811          else if (iqpere(iq).gt.0) then         
    812           if (tnom_0(iqpere(iq)) == tnom_trac) then
    813 !           write(lunout,*) 'Ce traceur est le fils d''un isotope'
    814            ! c'est un traceur d'isotope
    815            nb_traciso(ixt,phase)=nb_traciso(ixt,phase)+1
    816            iso_num(iq)=ixt
    817            iso_indnum(iq)=indnum_fn_num(ixt)
    818            zone_num(iq)=nb_traciso(ixt,phase)
    819            phase_num(iq)=phase
    820 !           write(lunout,*) 'iso_num(iq)=',iso_num(iq)
    821 !           write(lunout,*) 'phase_num(iq)=',phase_num(iq)
    822 !           write(lunout,*) 'zone_num(iq)=',zone_num(iq)
    823            goto 20
    824           endif !if (tnom_0(iqpere(iq)) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
    825          endif !IF (tnom_0(iq) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
    826         enddo !do ixt= niso_possibles
    827        enddo !do phase=1,nqo
    828   20   continue
    829       enddo !do iq=1,nqtot
    830 
    831 !      write(lunout,*) 'iso_num=',iso_num
    832 !      write(lunout,*) 'iso_indnum=',iso_indnum
    833 !      write(lunout,*) 'zone_num=',zone_num 
    834 !      write(lunout,*) 'phase_num=',phase_num
    835 !      write(lunout,*) 'indnum_fn_num=',indnum_fn_num
    836 
    837       do ixt= 1,niso_possibles 
    838 
    839         if (nb_iso(ixt,1).eq.1) then
    840           ! on vérifie que toutes les phases ont le même nombre de
    841           ! traceurs
    842           do phase=2,nqo
    843             if (nb_iso(ixt,phase).ne.nb_iso(ixt,1)) then
    844 !              write(lunout,*) 'ixt,phase,nb_iso=',ixt,phase,nb_iso(ixt,phase)
    845               CALL abort_gcm('infotrac_init','Phases must have same number of isotopes',1)
    846             endif
    847           enddo !do phase=2,nqo
    848 
    849           niso=niso+1
    850           use_iso(ixt)=.true.
    851           ntraceurs_zone=nb_traciso(ixt,1)
    852 
    853           ! on vérifie que toutes les phases ont le même nombre de
    854           ! traceurs
    855           do phase=2,nqo
    856             if (nb_traciso(ixt,phase).ne.ntraceurs_zone) then
    857               write(lunout,*) 'ixt,phase,nb_traciso=',ixt,phase,nb_traciso(ixt,phase)
    858               write(lunout,*) 'ntraceurs_zone=',ntraceurs_zone
    859               CALL abort_gcm('infotrac_init','Phases must have same number of tracers',1)
    860             endif 
    861           enddo  !do phase=2,nqo
    862           ! on vérifie que tous les isotopes ont le même nombre de
    863           ! traceurs
    864           if (ntraceurs_zone_prec.gt.0) then               
    865             if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
    866               ntraceurs_zone_prec=ntraceurs_zone
    867             else !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
    868               write(*,*) 'ntraceurs_zone_prec,ntraceurs_zone=',ntraceurs_zone_prec,ntraceurs_zone   
    869               CALL abort_gcm('infotrac_init', &
    870                &'Isotope tracers are not well defined in traceur.def',1)           
    871             endif !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
    872            endif !if (ntraceurs_zone_prec.gt.0) then
    873 
    874         else if (nb_iso(ixt,1).ne.0) then
    875            WRITE(lunout,*) 'nqo,ixt=',nqo,ixt
    876            WRITE(lunout,*) 'nb_iso(ixt,1)=',nb_iso(ixt,1)   
    877            CALL abort_gcm('infotrac_init','Isotopes are not well defined in traceur.def',1)     
    878         endif   !if (nb_iso(ixt,1).eq.1) then       
    879     enddo ! do ixt= niso_possibles
    880 
    881     ! dimensions isotopique:
    882     ntraciso=niso*(ntraceurs_zone+1)
    883 !    WRITE(lunout,*) 'niso=',niso
    884 !    WRITE(lunout,*) 'ntraceurs_zone,ntraciso=',ntraceurs_zone,ntraciso   
    885  
    886     ! flags isotopiques:
    887     if (niso.gt.0) then
    888         ok_isotopes=.true.
    889     else
    890         ok_isotopes=.false.
    891     endif
    892 !    WRITE(lunout,*) 'ok_isotopes=',ok_isotopes
    893  
    894     if (ok_isotopes) then
    895         ok_iso_verif=.false.
    896         call getin('ok_iso_verif',ok_iso_verif)
    897         ok_init_iso=.false.
    898         call getin('ok_init_iso',ok_init_iso)
    899         tnat=(/1.0,155.76e-6,2005.2e-6,0.004/100.,0.0/)
    900         alpha_ideal=(/1.0,1.01,1.006,1.003,1.0/)
    901     endif !if (ok_isotopes) then 
    902 !    WRITE(lunout,*) 'ok_iso_verif=',ok_iso_verif
    903 !    WRITE(lunout,*) 'ok_init_iso=',ok_init_iso
    904 
    905     if (ntraceurs_zone.gt.0) then
    906         ok_isotrac=.true.
    907     else
    908         ok_isotrac=.false.
    909     endif   
    910 !    WRITE(lunout,*) 'ok_isotrac=',ok_isotrac
    911 
    912     ! remplissage du tableau iqiso(ntraciso,phase)
    913     ALLOCATE(iqiso(ntraciso,nqo))   
    914     iqiso(:,:)=0     
    915     do iq=1,nqtot
    916         if (iso_num(iq).gt.0) then
    917           ixt=iso_indnum(iq)+zone_num(iq)*niso
    918           iqiso(ixt,phase_num(iq))=iq
    919         endif
    920     enddo
    921 !    WRITE(lunout,*) 'iqiso=',iqiso
    922 
    923     ! replissage du tableau index_trac(ntraceurs_zone,niso)
    924     ALLOCATE(index_trac(ntraceurs_zone,niso)) 
    925     if (ok_isotrac) then
    926         do iiso=1,niso
    927           do izone=1,ntraceurs_zone
    928              index_trac(izone,iiso)=iiso+izone*niso
    929           enddo
    930         enddo
    931     else !if (ok_isotrac) then     
    932         index_trac(:,:)=0.0
    933     endif !if (ok_isotrac) then
    934 !    write(lunout,*) 'index_trac=',index_trac   
    935 
    936 ! Finalize :
    937     DEALLOCATE(nb_iso)
    938 
    939   END SUBROUTINE infotrac_isoinit
     528
     529    !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list
     530    !    (including tagging tracers) is sorted this way:  iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
     531    s%iTraPha = RESHAPE( [( (strIdx(t(:)%name,  addPhase(s%trac(it),s%phas(ip:ip))),     it=1, s%nitr), ip=1, s%npha)], &
     532                         [s%nitr, s%npha] )
     533
     534    !=== Table used to get ix (index in tagging tracers isotopes list, size nitr) from the zone and isotope indexes
     535    s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzon), it=1, s%niso)], &
     536                         [s%nzon, s%niso] )
     537  END DO
     538
     539  !=== Indexes, in dynamical tracers list, of the tracers transmitted to phytrac (nqtottr non-vanishing elements)
     540  ll = delPhase(t%name)/='H2O' .AND. t%iso_num ==0              !--- Mask of tracers passed to the physics
     541  t(:)%itr = UNPACK([(iq,iq=1,COUNT(ll))], ll, [(0, iq=1, nqtot)])
     542  itr_indice = PACK(t(:)%itr, MASK = t(:)%itr/=0)               !--- Might be removed (t%itr should be enough)
     543
     544  !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE
     545  !    DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat AND alpha_ideal)
     546  IF(readIsotopesFile('isotopes_params.def',isotopes)) CALL abort_gcm(modname,'Problem when reading isotopes parameters',1)
     547print*,'coincoin'
     548
     549  !=== Specific to water
     550  CALL getKey_init(tracers, isotopes)
     551  IF(isoSelect('H2O')) RETURN                                   !--- Select water isotopes ; finished if no water isotopes.
     552  iH2O = ixIso                                                  !--- Keep track of water family index
     553  lerr = getKey('tnat' ,tnat,        isoName)
     554  lerr = getKey('alpha',alpha_ideal, isoName)
     555  CALL msg('end')
     556
     557END SUBROUTINE infotrac_init
     558
     559
     560!==============================================================================================================================
     561!=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED
     562!     Singe generic "isoSelect" routine, using the predefined parent index (fast version) or its name (first time).
     563!==============================================================================================================================
     564LOGICAL FUNCTION isoSelectByName(iName) RESULT(lerr)
     565  CHARACTER(LEN=*), INTENT(IN)  :: iName
     566  INTEGER :: iIso
     567  iIso = strIdx(isotopes(:)%prnt, iName)
     568  IF(test(fmsg(iIso == 0,'no isotope family named "'//TRIM(iName)//'"'),lerr)) RETURN
     569  IF(isoSelectByIndex(iIso)) RETURN
     570END FUNCTION isoSelectByName
     571!==============================================================================================================================
     572LOGICAL FUNCTION isoSelectByIndex(iIso) RESULT(lerr)
     573  INTEGER, INTENT(IN) :: iIso
     574  lerr = .FALSE.
     575  IF(iIso == ixIso) RETURN                                      !--- Nothing to do if the index is already OK
     576  IF(test(fmsg(iIso<=0 .OR. iIso>=nbIso,'Inconsistent isotopes family index '//TRIM(int2str(iIso))),lerr)) RETURN
     577  ixIso = iIso                                                  !--- Update currently selected family index
     578  isotope => isotopes(ixIso)                                    !--- Select corresponding component
     579  !--- VARIOUS ALIASES
     580  isoKeys => isotope%keys; niso = isotope%niso
     581  isoName => isotope%trac; nitr = isotope%nitr; isoCheck => isotope%check
     582  isoZone => isotope%zone; nzon = isotope%nzon; iZonIso  => isotope%iZonIso
     583  isoPhas => isotope%phas; npha = isotope%npha; iTraPha  => isotope%iTraPha
     584END FUNCTION isoSelectByIndex
     585!==============================================================================================================================
    940586
    941587END MODULE infotrac

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/initdynav.F90

    r2622 r3852  
    66  USE IOIPSL
    77#endif
    8   USE infotrac, ONLY : nqtot, ttext
     8  USE infotrac, ONLY : nqtot
    99  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
    1010       dynhistave_file,dynhistvave_file,dynhistuave_file
    … …  
    158158
    159159  !        DO iq=1,nqtot
    160   !          call histdef(histaveid, ttext(iq), ttext(iq), '-', &
     160  !          call histdef(histaveid, tracers(iq)%lnam, &
     161  !                  tracers(iq)%lnam, '-', &
    161162  !                  iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
    162163  !                  32, 'ave(X)', t_ops, t_wrt)

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/inithist.F

    r2622 r3852  
    77       USE IOIPSL
    88#endif
    9        USE infotrac, ONLY : nqtot, ttext
     9       USE infotrac, ONLY : nqtot
    1010       use com_io_dyn_mod, only : histid,histvid,histuid,               &
    1111     &                        dynhist_file,dynhistv_file,dynhistu_file
    … …  
    157157!
    158158!        DO iq=1,nqtot
    159 !          call histdef(histid, ttext(iq),  ttext(iq), '-',
    160 !     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     159!          call histdef(histid, tracers(iq)lnam, tracers(iq)%lnam,
     160!     .             '-', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    161161!     .             32, 'inst(X)', t_ops, t_wrt)
    162162!        enddo

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/iso_verif_dyn.F90

    r3850 r3852  
    1         function iso_verif_noNaN_nostop(x,err_msg)
    2         implicit none
    3         ! si x est NaN, on affiche message
    4         ! d'erreur et return 1 si erreur
     1LOGICAL FUNCTION iso_verif_noNaN_nostop(x,err_msg) RESULT(out)
     2  USE infotrac, ONLY: isoCheck
     3  IMPLICIT NONE
     4  !--- Display the message if x is NaN and return .TRUE. if an error occured.
     5  REAL,             INTENT(IN) :: x
     6  CHARACTER(LEN=*), INTENT(IN) :: err_msg
     7  include "iniprint.h"
     8  REAL, PARAMETER :: borne=1e19
     9  out = .FALSE.
     10  IF(.NOT.isoCheck) RETURN
     11  out = x<=-borne .OR. x>=borne
     12  IF(.NOT.out) RETURN
     13  WRITE(lunout,*) 'Error detected by iso_verif_noNaN: '//TRIM(err_msg)
     14  WRITE(lunout,*) 'x=',x
     15END FUNCTION iso_verif_noNaN_nostop
    516
    6         ! input:
    7         real x
    8         character*(*) err_msg ! message d''erreur à afficher
     17LOGICAL FUNCTION iso_verif_egalite_nostop(a,b,err_msg) RESULT(out)
     18  USE infotrac, ONLY: isoCheck
     19  IMPLICIT NONE
     20  !--- Display the message if a/=b and return .FALSE. if an error occured.
     21  !    Equality is checked for absolute and relative error.
     22  REAL,             INTENT(IN) :: a,b
     23  CHARACTER(LEN=*), INTENT(IN) :: err_msg
     24  include "iniprint.h"
     25  REAL, PARAMETER :: errmax=1e-8, errmaxrel=1e-3
     26  out = .FALSE.
     27  IF(.NOT.isoCheck) RETURN
     28  out = ABS(a-b)>errmax
     29  IF(out) out = ABS((a-b)/MAX(MAX(ABS(b),ABS(a)),1e-18))>errmaxrel
     30  IF(.NOT.out)      RETURN
     31  WRITE(lunout,*) 'Error detected by iso_verif_egalite: '//TRIM(err_msg)
     32  WRITE(lunout,*) 'a=',a
     33  WRITE(lunout,*) 'b=',b
     34END FUNCTION iso_verif_egalite_nostop
    935
    10         ! output
    11         real borne
    12         parameter (borne=1e19)
    13         integer iso_verif_noNaN_nostop
     36LOGICAL FUNCTION iso_verif_aberrant_nostop(x,kiso,q,err_msg) RESULT(out)
     37  USE infotrac, ONLY: isoCheck, tnat
     38  IMPLICIT NONE
     39  !--- Display the message if a/=b and return .FALSE. if an error occured.
     40  !    Equality is checked for absolute and relative error.
     41  REAL,             INTENT(IN) :: x, q
     42  INTEGER,          INTENT(IN) :: kiso ! 2=HDO, 1=O18
     43  CHARACTER(LEN=*), INTENT(IN) :: err_msg
     44  include "iniprint.h"
     45  REAL, PARAMETER :: qmin=1e-11, deltaDmax=200.0, deltaDmin=-999.9
     46  REAL :: deltaD
     47  out = .FALSE.
     48  IF(.NOT.isoCheck) RETURN
     49  IF(q<qmin)        RETURN
     50  deltaD = (x/q/tnat(kiso)-1)*1000
     51  out = deltaD>deltaDmax .OR. deltaD<deltaDmin
     52  IF(.NOT.out)      RETURN
     53  WRITE(lunout,*) 'Error detected by iso_verif_aberrant: '//TRIM(err_msg)
     54  WRITE(lunout,*) 'q = ',q
     55  WRITE(lunout,*) 'deltaD = ',deltaD
     56  WRITE(lunout,*) 'kiso = ',kiso
     57END FUNCTION iso_verif_aberrant_nostop
    1458
    15         if ((x.gt.-borne).and.(x.lt.borne)) then
    16                 iso_verif_noNAN_nostop=0
    17         else
    18             write(*,*) 'erreur detectee par iso_verif_nonNaN:'
    19             write(*,*) err_msg
    20             write(*,*) 'x=',x
    21             iso_verif_noNaN_nostop=1
    22         endif     
    23 
    24         return
    25         end
    26 
    27         function iso_verif_egalite_nostop
    28      :           (a,b,err_msg)
    29         implicit none
    30         ! compare a et b. Si pas egal, on affiche message
    31         ! d'erreur et stoppe
    32         ! pour egalite, on verifie erreur absolue et arreur relative
    33 
    34         ! input:
    35         real a, b
    36         character*(*) err_msg ! message d''erreur à afficher
    37 
    38         ! locals
    39         real errmax ! erreur maximale en absolu.
    40         real errmaxrel ! erreur maximale en relatif autorisée
    41         parameter (errmax=1e-8)
    42         parameter (errmaxrel=1e-3)
    43 
    44         ! output
    45         integer iso_verif_egalite_nostop
    46 
    47         iso_verif_egalite_nostop=0
    48 
    49         if (abs(a-b).gt.errmax) then
    50           if (abs((a-b)/max(max(abs(b),abs(a)),1e-18))
    51      :            .gt.errmaxrel) then
    52             write(*,*) 'erreur detectee par iso_verif_egalite:'
    53             write(*,*) err_msg
    54             write(*,*) 'a=',a
    55             write(*,*) 'b=',b
    56             iso_verif_egalite_nostop=1
    57           endif
    58         endif     
    59        
    60         return
    61         end       
    62 
    63 
    64         function iso_verif_aberrant_nostop
    65      :           (x,iso,q,err_msg)
    66         USE infotrac
    67         implicit none
    68        
    69         ! input:
    70         real x,q
    71         integer iso ! 2=HDO, 1=O18
    72         character*(*) err_msg ! message d''erreur à afficher
    73 
    74         ! locals
    75         real qmin,deltaD
    76         real deltaDmax,deltaDmin
    77         parameter (qmin=1e-11)
    78         parameter (deltaDmax=200.0,deltaDmin=-999.9)
    79 
    80         ! output
    81         integer iso_verif_aberrant_nostop
    82 
    83         iso_verif_aberrant_nostop=0
    84 
    85         ! verifier que HDO est raisonable
    86          if (q.gt.qmin) then
    87              deltaD=(x/q/tnat(iso)-1)*1000
    88              if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    89                   write(*,*) 'erreur detectee par iso_verif_aberrant:'
    90                   write(*,*) err_msg
    91                   write(*,*) 'q=',q
    92                   write(*,*) 'deltaD=',deltaD
    93                   write(*,*) 'iso=',iso
    94                   iso_verif_aberrant_nostop=1
    95              endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    96           endif !if (q(i,k,iq).gt.qmin) then
    97 
    98        
    99         return
    100         end       
    101 

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/massbarxy.F90

    r2597 r3852  
    2121    DO ij=1,ip1jm-1
    2222      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
    23      +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
    24      +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
    25      +               masse(ij+iip2,l)*alpha4(ij+iip2)
     23                     masse(ij+1   ,l)*alpha3(ij+1   ) + &
     24                     masse(ij+iip1,l)*alpha1(ij+iip1) + &
     25                     masse(ij+iip2,l)*alpha4(ij+iip2)
    2626    END DO
    2727    DO ij=iip1,ip1jm,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/writedynav.F90

    r2622 r3852  
    66  USE ioipsl
    77#endif
    8   USE infotrac, ONLY : nqtot, ttext
     8  USE infotrac, ONLY : nqtot
    99  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
    1010  USE comconst_mod, ONLY: cpp
    … …  
    106106
    107107  !  DO iq=1, nqtot
    108   !       call histwrite(histaveid, ttext(iq), itau_w, q(:, :, iq), &
    109   !                   iip1*jjp1*llm, ndexu)
     108  !       call histwrite(histaveid, tracers(iq)%lnam, itau_w, &
     109  !                      q(:, :, iq), iip1*jjp1*llm, ndexu)
    110110  ! enddo
    111111

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/writehist.F

    r2622 r3852  
    77      USE ioipsl
    88#endif
    9       USE infotrac, ONLY : nqtot, ttext
     9      USE infotrac, ONLY : nqtot
    1010      use com_io_dyn_mod, only : histid,histvid,histuid
    1111      USE temps_mod, ONLY: itau_dyn
    … …  
    100100C
    101101!        DO iq=1,nqtot
    102 !          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq),
     102!          call histwrite(histid, tracers(iq)%lnam, itau_w, q(:,:,iq),
    103103!     .                   iip1*jjp1*llm, ndexu)
    104104!        enddo

  • 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

  • LMDZ6/branches/LMDZ-tracers/libf/dynphy_lonlat/calfis.F

    r2604 r3852  
    2929c    Auteur :  P. Le Van, F. Hourdin
    3030c   .........
    31       USE infotrac, ONLY: nqtot, niadv, tname
     31      USE infotrac, ONLY: nqtot, niadv, tracers
    3232      USE control_mod, ONLY: planet_type, nsplit_phys
    3333#ifdef CPP_PHYS
    … …  
    481481         lafin_split=lafin.and.isplit==nsplit_phys
    482482
    483         CALL call_physiq(ngridmx,llm,nqtot,tname,
     483        CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name,
    484484     &                   debut_split,lafin_split,
    485485     &                   jD_cur,jH_cur_split,zdt_split,

  • LMDZ6/branches/LMDZ-tracers/libf/dynphy_lonlat/calfis_loc.F

    r2604 r3852  
    4545      USE Times
    4646#endif
    47       USE infotrac, ONLY: nqtot, niadv, tname
     47      USE infotrac, ONLY: nqtot, niadv, tracers
    4848      USE control_mod, ONLY: planet_type, nsplit_phys
    4949#ifdef CPP_PHYS
    … …  
    731731         lafin_split=lafin.and.isplit==nsplit_phys
    732732
    733         CALL call_physiq(klon,llm,nqtot,tname,
     733        CALL call_physiq(klon,llm,nqtot,tracers(:)%name,
    734734     &                   debut_split,lafin_split,
    735735     &                   jD_cur,jH_cur_split,zdt_split,

  • LMDZ6/branches/LMDZ-tracers/libf/dynphy_lonlat/calfis_p.F

    r2604 r3852  
    4242      USE Times
    4343#endif
    44       USE infotrac, ONLY: nqtot, niadv, tname
     44      USE infotrac, ONLY: nqtot, niadv, tracers
    4545      USE control_mod, ONLY: planet_type, nsplit_phys
    4646#ifdef CPP_PHYS
    … …  
    697697         lafin_split=lafin.and.isplit==nsplit_phys
    698698
    699         CALL call_physiq(klon,llm,nqtot,tname,
     699        CALL call_physiq(klon,llm,nqtot,tracers(:)%name,
    700700     &                   debut_split,lafin_split,
    701701     &                   jD_cur,jH_cur_split,zdt_split,

  • LMDZ6/branches/LMDZ-tracers/libf/dynphy_lonlat/phylmd/etat0dyn_netcdf.F90

    r3435 r3852  
    7474  USE exner_hyb_m,    ONLY: exner_hyb
    7575  USE exner_milieu_m, ONLY: exner_milieu
    76   USE infotrac,       ONLY: nqtot, tname
     76  USE infotrac,       ONLY: nqtot, tracers
    7777  USE filtreg_mod
    7878  IMPLICIT NONE
    … …  
    145145! Look for ozone tracer:
    146146#ifndef INCA
    147   DO i=1,nqtot; IF(ANY(["O3","o3"]==tname(i))) EXIT; END DO
     147  DO i=1,nqtot; IF(ANY(["O3","o3"]==tracers(i)%name)) EXIT; END DO
    148148  IF(i/=nqtot+1) THEN
    149149    CALL regr_lat_time_coefoz

  • LMDZ6/branches/LMDZ-tracers/libf/dynphy_lonlat/phylmd/iniphysiq_mod.F90

    r3677 r3852  
    1616  USE mod_phys_lmdz_para, ONLY: klon_omp ! number of columns (on local omp grid)
    1717  USE vertical_layers_mod, ONLY : init_vertical_layers
    18   USE infotrac, ONLY: nqtot,nqo,nbtr,tname,ttext,type_trac,&
    19                       niadv,conv_flg,pbl_flg,solsym,&
    20                       nqfils,nqdesc,nqdesc_tot,iqfils,iqpere,&
    21                       ok_isotopes,ok_iso_verif,ok_isotrac,&
    22                       ok_init_iso,niso_possibles,tnat,&
    23                       alpha_ideal,use_iso,iqiso,iso_num,&
    24                       iso_indnum,zone_num,phase_num,&
    25                       indnum_fn_num,index_trac,&
    26                       niso,ntraceurs_zone,ntraciso
     18  USE infotrac, ONLY: tracers, isotopes, type_trac, solsym, nbtr, niadv, pbl_flg, conv_flg
    2719#ifdef CPP_StratAer
    2820  USE infotrac, ONLY: nbtr_bin, nbtr_sulgas, id_OCS_strat, &
    … …  
    146138
    147139  ! Initialize tracer names, numbers, etc. for physics
    148   CALL init_infotrac_phy(nqtot,nqo,nbtr,tname,ttext,type_trac,&
    149                          niadv,conv_flg,pbl_flg,solsym,&
    150                          nqfils,nqdesc,nqdesc_tot,iqfils,iqpere,&
    151                          ok_isotopes,ok_iso_verif,ok_isotrac,&
    152                          ok_init_iso,niso_possibles,tnat,&
    153                          alpha_ideal,use_iso,iqiso,iso_num,&
    154                          iso_indnum,zone_num,phase_num,&
    155                          indnum_fn_num,index_trac,&
    156                          niso,ntraceurs_zone,ntraciso&
     140  CALL init_infotrac_phy(tracers, isotopes, type_trac, solsym, nbtr, niadv, pbl_flg, conv_flg &
    157141#ifdef CPP_StratAer
    158142                         ,nbtr_bin,nbtr_sulgas&
    … …  
    183167#endif
    184168  END IF
    185   IF (type_trac == 'repr') THEN
    186 #ifdef REPROBUS
    187     call init_reprobus_para( &
    188           nbp_lon,nbp_lat,nbp_lev,klon_glo,mpi_size, &
    189           distrib_phys,communicator)
    190 #endif
    191   ENDIF
    192169
    193170!!$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/)
    … …  
    203180          rlonudyn,rlatudyn,rlonvdyn,rlatvdyn)
    204181#endif
    205     IF (type_trac == 'repr') THEN
    206 #ifdef REPROBUS
    207        CALL Init_chem_rep_phys(klon_omp,nbp_lev)
    208 #endif
    209     END IF
    210182  END IF
    211183

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/cvltr.F90

    r2320 r3852  
    1212  USE IOIPSL
    1313  USE dimphy
    14   USE infotrac_phy, ONLY : nbtr,tname
     14  USE infotrac_phy, ONLY : nbtr
    1515  IMPLICIT NONE
    1616!=====================================================================

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/cvltr_scav.F90

    r2320 r3852  
    1313  USE IOIPSL
    1414  USE dimphy
    15   USE infotrac_phy, ONLY : nbtr,tname
     15  USE infotrac_phy, ONLY : nbtr
    1616  IMPLICIT NONE
    1717  !=====================================================================

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/cvltr_spl.F90

    r2320 r3852  
    1313  USE IOIPSL
    1414  USE dimphy
    15   USE infotrac_phy, ONLY : nbtr,tname
     15  USE infotrac_phy, ONLY : nbtr
    1616  IMPLICIT NONE
    1717!=====================================================================

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/infotrac_phy.F90

    r3677 r3852  
    1 
    2 ! $Id: $
    3 
    41MODULE infotrac_phy
    52
    6 ! Infotrac for physics; for now contains the same information as infotrac for
    7 ! the dynamics (could be further cleaned) and is initialized using values
    8 ! provided by the dynamics
    9 
    10 ! nqtot : total number of tracers and higher order of moment, water vapor and liquid included
    11   INTEGER, SAVE :: nqtot
    12 !$OMP THREADPRIVATE(nqtot)
    13 
    14 !CR: on ajoute le nombre de traceurs de l eau
    15   INTEGER, SAVE :: nqo
    16 !$OMP THREADPRIVATE(nqo)
    17 
    18 ! nbtr : number of tracers not including higher order of moment or water vapor or liquid
    19 !        number of tracers used in the physics
    20   INTEGER, SAVE :: nbtr
    21 !$OMP THREADPRIVATE(nbtr)
    22 
     3  USE       strings_mod, ONLY: msg, fmsg, test, strIdx, int2str
     4
     5  USE readTracFiles_mod, ONLY: getKey_init, getKey, indexUpdate
     6
     7  USE trac_types_mod,    ONLY: tra, iso, kys
     8
     9  IMPLICIT NONE
     10
     11  PRIVATE
     12
     13  !=== FOR TRACERS:
     14  PUBLIC :: tra,   tracers,  type_trac                     !--- Derived type, full database, tracers type keyword
     15  PUBLIC :: nqtot,   nbtr,   nqo                           !--- Main dimensions
     16  PUBLIC :: init_infotrac_phy                              !--- Initialization
     17  PUBLIC :: itr_indice                                     !--- Indexes of the tracers passed to phytrac
     18  PUBLIC :: niadv                                          !--- Indexes of true tracers (<=nqtot, such that iadv(idx)>0)
     19  PUBLIC :: pbl_flg, conv_flg, solsym
     20
     21  !=== FOR ISOTOPES: General
     22  !--- General
     23  PUBLIC :: iso, isotopes, nbIso                           !--- Derived type, full isotopes families database + nb of families
     24  PUBLIC :: isoSelect , ixIso                              !--- Isotopes family selection tool + selected family index
     25  !=== FOR ISOTOPES: Specific to H2O isotopes
     26  PUBLIC :: iH2O, tnat, alpha_ideal                        !--- H2O isotopes index, natural abundance, fractionning coeff.
     27  !=== FOR ISOTOPES: Depending on selected isotopes family
     28  PUBLIC :: isotope, isoKeys                               !--- Selected isotopes database + associated keys (cf. getKey)
     29  PUBLIC :: isoName, isoZone, isoPhas                      !--- Isotopes and tagging zones names, phases
     30  PUBLIC :: niso, nzon, npha, nitr                         !---  " " numbers + isotopes & tagging tracers number
     31  PUBLIC :: iZonIso, iTraPha                               !--- 2D index tables to get "iq" index
     32  PUBLIC :: isoCheck                                       !--- Run isotopes checking routines
     33
     34  !=== FOR BOTH TRACERS AND ISOTOPES
     35  PUBLIC :: getKey                                         !--- Get a key from "tracers" or "isotope"
     36
     37  !=== FOR STRATOSPHERIC AEROSOLS
    2338#ifdef CPP_StratAer
    24 ! nbtr_bin: number of aerosol bins for StratAer model
    25 ! nbtr_sulgas: number of sulfur gases for StratAer model
    26   INTEGER, SAVE :: nbtr_bin, nbtr_sulgas
    27 !$OMP THREADPRIVATE(nbtr_bin,nbtr_sulgas)
    28   INTEGER, SAVE :: id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat
    29 !$OMP THREADPRIVATE(id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat)
     39  PUBLIC :: nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat
    3040#endif
    3141
    32 ! CRisi: nb traceurs pères= directement advectés par l'air
    33   INTEGER, SAVE :: nqperes
    34 !$OMP THREADPRIVATE(nqperes)
    35 
    36 ! Name variables
    37   CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
    38   CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics
    39 !$OMP THREADPRIVATE(tname,ttext)
    40 
    41 !! iadv  : index of trasport schema for each tracer
    42 !  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iadv
    43 
    44 ! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the
    45 !         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code.
    46   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
    47 !$OMP THREADPRIVATE(niadv)
    48 
    49 ! CRisi: tableaux de fils
    50   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqfils
    51   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqdesc ! nombres de fils + nombre de tous les petits fils sur toutes les générations
    52   INTEGER, SAVE :: nqdesc_tot
    53   INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE    :: iqfils
    54   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iqpere
    55 !$OMP THREADPRIVATE(nqfils,nqdesc,nqdesc_tot,iqfils,iqpere)
    56 
    57 ! conv_flg(it)=0 : convection desactivated for tracer number it
    58   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: conv_flg
    59 !$OMP THREADPRIVATE(conv_flg)
    60 
    61 ! pbl_flg(it)=0  : boundary layer diffusion desactivaded for tracer number it
    62   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: pbl_flg
    63 !$OMP THREADPRIVATE(pbl_flg)
    64 
    65   CHARACTER(len=4),SAVE :: type_trac
    66 !$OMP THREADPRIVATE(type_trac)
    67   CHARACTER(len=8),DIMENSION(:),ALLOCATABLE, SAVE :: solsym
    68 !$OMP THREADPRIVATE(solsym)
    69    
    70     ! CRisi: cas particulier des isotopes
    71     LOGICAL,SAVE :: ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso
    72 !$OMP THREADPRIVATE(ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso)
    73     INTEGER :: niso_possibles   
    74     PARAMETER ( niso_possibles=5)
    75     real, DIMENSION (niso_possibles),SAVE :: tnat,alpha_ideal
    76 !$OMP THREADPRIVATE(tnat,alpha_ideal)
    77     LOGICAL, DIMENSION(niso_possibles),SAVE ::  use_iso
    78 !$OMP THREADPRIVATE(use_iso)
    79     INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  iqiso ! donne indice iq en fn de (ixt,phase)
    80 !$OMP THREADPRIVATE(iqiso)
    81     INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_num ! donne numéro iso entre 1 et niso_possibles en fn de nqtot
    82 !$OMP THREADPRIVATE(iso_num)
    83     INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_indnum ! donne numéro iso entre 1 et niso effectif en fn de nqtot
    84 !$OMP THREADPRIVATE(iso_indnum)
    85     INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  zone_num ! donne numéro de la zone de tracage en fn de nqtot
    86 !$OMP THREADPRIVATE(zone_num)
    87     INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  phase_num ! donne numéro de la zone de tracage en fn de nqtot
    88 !$OMP THREADPRIVATE(phase_num)
    89     INTEGER, DIMENSION(niso_possibles), SAVE :: indnum_fn_num ! donne indice entre entre 1 et niso en fonction du numéro d isotope entre 1 et niso_possibles
    90 !$OMP THREADPRIVATE(indnum_fn_num)
    91     INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  index_trac ! numéro ixt en fn izone, indnum entre 1 et niso
    92 !$OMP THREADPRIVATE(index_trac)
    93     INTEGER,SAVE :: niso,ntraceurs_zone,ntraciso
    94 !$OMP THREADPRIVATE(niso,ntraceurs_zone,ntraciso)
    95  
     42  INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect
     43
     44!=== CONVENTIONS FOR TRACERS NUMBERS:
     45!  |--------------------+----------------------+-----------------+---------------+----------------------------|
     46!  | water in different |    water tagging     |  water isotopes | other tracers | additional tracers moments |
     47!  | phases: H2O-[gls]  |      isotopes        |                 |               |  for higher order schemes  |
     48!  |--------------------+----------------------+-----------------+---------------+----------------------------|
     49!  |                    |                      |                 |               |                            |
     50!  |<--     nqo      -->|<-- nqo*niso* nzon -->|<-- nqo*niso  -->|<--  nbtr   -->|<--        (nmom)        -->|         
     51!  |                    |                                        |                                            |
     52!  |                    |<-- nqo*niso*(nzon+1)  =   nqo*nitr  -->|<--    nqtottr = nbtr + nmom             -->|
     53!  |                                                                             = nqtot - nqo*(nitr+1)       |
     54!  |                                                                                                          |
     55!  |<--                        nqtrue  =  nbtr + nqo*(nitr+1)                 -->|                            |
     56!  |                                                                                                          |
     57!  |<--                        nqtot   =  nqtrue + nmom                                                    -->|
     58!  |                                                                                                          |
     59!  |----------------------------------------------------------------------------------------------------------|
     60! NOTES FOR THIS TABLE:
     61!  * The used "niso", "nzon" and "nitr" are the H2O components of "isotopes(ip)"  (isotopes(ip)%prnt == 'H2O'),
     62!    since water is so far the sole tracers family removed from the main tracers table.
     63!  * For water, "nqo" is equal to the more general field "isotopes(ip)%npha".
     64!  * "niso", "nzon", "nitr", "npha" are defined for other isotopic tracers families, if any.
     65!
     66!=== TRACERS DESCRIPTOR: DERIVED TYPE EMBEDDING MOST OF THE USEFUL QUANTITIES (LENGTH: nqtot)
     67!    Each entry is accessible using "%" sign.
     68!  |------------+-------------------------------------------------+-------------+------------------------+
     69!  |  entry     | Meaning                                         | Former name | Possible values        |
     70!  |------------+-------------------------------------------------+-------------+------------------------+
     71!  | name       | Name (short)                                    | tname       |                        |
     72!  | nam1       | Name of the 1st generation ancestor             | /           |                        |
     73!  | prnt       | Name of the parent                              | /           |                        |
     74!  | lnam       | Long name (with adv. scheme suffix) for outputs | ttext       |                        |
     75!  | type       | Type (so far: tracer or tag)                    | /           | tracer,tag             |
     76!  | phas       | Phases list ("g"as / "l"iquid / "s"olid)        | /           | [g][l][s]              |
     77!  | iadv       | Advection scheme number                         | iadv        | 1-20,30 exc. 3-9,15,19 |
     78!  | igen       | Generation (>=1)                                | /           |                        |
     79!  | itr        | Index in "tr_seri" (0: absent from physics)     | cf. niadv   | 1:nqtottr              |
     80!  | iprnt      | Index of the parent tracer                      | iqpere      | 1:nqtot                |
     81!  | idesc      | Indexes of the childs (all generations)         | iqfils      | 1:nqtot                |
     82!  | ndesc      | Number of the descendants (all generations)     | nqdesc      | 1:nqtot                |
     83!  | nchld      | Number of childs (first generation only)        | nqfils      | 1:nqtot                |
     84!  | keys       | key/val pairs accessible with "getKey" routine  | /           |                        |
     85!  | iso_num    | Isotope name  index in iso(igr)%name(:)         | iso_indnum  | 1:niso                 |
     86!  | iso_zon    | Isotope zone  index in iso(igr)%zone(:)         | zone_num    | 1:nzon                 |
     87!  | iso_pha    | Isotope phase index in iso(igr)%phas            | phase_num   | 1:npha                 |
     88!  +------------+-------------------------------------------------+-------------+------------------------+
     89!
     90!=== ISOTOPES DESCRIPTOR: DERIVED TYPE EMBEDDING MOST OF THE USEFUL QUANTITIES (LENGTH: NUMBER OF ISOTOPES FAMILIES USED)
     91!    Each entry is accessible using "%" sign.
     92!  |------------+-------------------------------------------------+-------------+-----------------------+
     93!  |  entry     | Meaning                                         | Former name | Possible values       |
     94!  |------------+-------------------------------------------------+-------------+-----------------------+
     95!  | prnt       | Parent tracer (isotopes family name)            |             |                       |
     96!  | trac, nitr | Isotopes & tagging tracers + number of elements |             |                       |
     97!  | zone, nzon | Geographic tagging zones   + number of elements |             |                       |
     98!  | phas, npha | Phases list                + number of elements |             | [g][l][s], 1:3        |
     99!  | niso       | Number of isotopes, excluding tagging tracers   |             |                       |
     100!  | iTraPha    | Index in "xt" = f(iname(niso+1:nitr),iphas)     | iqiso       | 1:niso                |
     101!  | iZonIso    | Index in "xt" = f(izone, iname(1:niso))         | index_trac  | 1:nzon                |
     102!  |------------+-------------------------------------------------+-------------+-----------------------+
     103
     104  !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES
     105  INTEGER,            SAVE :: nqtot, &                     !--- Tracers nb in dynamics (incl. higher moments & water)
     106                              nbtr,  &                     !--- Tracers nb in physics  (excl. higher moments & water)
     107                              nqo,   &                     !--- Number of water phases
     108                              nbIso                        !--- Number of available isotopes family
     109  CHARACTER(LEN=256), SAVE :: type_trac                    !--- Keyword for tracers type
     110
     111  !=== DERIVED TYPES EMBEDDING MOST INFORMATIONS ABOUT TRACERS AND ISOTOPES FAMILIES
     112  TYPE(tra), TARGET,  SAVE, ALLOCATABLE ::  tracers(:)     !=== TRACERS DESCRIPTORS VECTOR
     113  TYPE(iso), TARGET,  SAVE, ALLOCATABLE :: isotopes(:)     !=== ISOTOPES PARAMETERS VECTOR
     114!$OMP THREADPRIVATE(tracers, isotopes)
     115
     116  !=== ALIASES FOR CURRENTLY SELECTED ISOTOPES FAMILY OF VARIABLES EMBEDDED IN THE VECTOR "isotopes"
     117  TYPE(iso),          SAVE, POINTER :: isotope             !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR
     118  INTEGER,            SAVE          :: ixIso, iH2O         !--- Index of the selected isotopes family and H2O family
     119  LOGICAL,            SAVE, POINTER :: isoCheck            !--- Flag to trigger the checking routines
     120  TYPE(kys),          SAVE, POINTER :: isoKeys(:)          !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName)
     121  CHARACTER(LEN=256), SAVE, POINTER :: isoName(:),       & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY
     122                                       isoZone(:),       & !--- TAGGING ZONES  FOR THE CURRENTLY SELECTED FAMILY
     123                                       isoPhas             !--- USED PHASES    FOR THE CURRENTLY SELECTED FAMILY
     124  INTEGER,            SAVE          :: niso, nzon, npha, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES
     125                                       nitr                !--- NUMBER OF ISOTOPES + ISOTOPIC TAGGING TRACERS
     126  INTEGER,            SAVE, POINTER :: iZonIso(:,:)        !--- INDEX IN "isoTrac" AS f(tagging zone, isotope)
     127  INTEGER,            SAVE, POINTER :: iTraPha(:,:)        !=== INDEX IN "isoTrac" AS f(isotopic tracer, phase)
     128!$OMP THREADPRIVATE(isotope, ixIso,iH2O, isoCheck, isoKeys, isoName,isoZone,isoPhas, niso,nzon,npha,nitr, iZonIso,iTraPha)
     129
     130  !=== VARIABLES EMBEDDED IN "tracers", BUT DUPLICATED, AS THEY ARE RATHER FREQUENTLY USED + VARIABLES FOR INCA
     131  REAL,               SAVE, ALLOCATABLE ::     tnat(:),  & !--- Natural relative abundance of water isotope        (niso)
     132                                        alpha_ideal(:)     !--- Ideal fractionning coefficient (for initial state) (niso)
     133  INTEGER,            SAVE, ALLOCATABLE :: conv_flg(:),  & !--- Convection     activation ; needed for INCA        (nbtr)
     134                                            pbl_flg(:)     !---  Boundary layer activation ; needed for INCA        (nbtr)
     135  INTEGER,            SAVE, ALLOCATABLE ::    niadv(:),  &
     136                                         itr_indice(:)     !--- Indexes of the tracers passed to phytrac        (nqtottr)
     137  CHARACTER(LEN=256), SAVE, ALLOCATABLE ::   solsym(:)     !--- Names from INCA                                    (nbtr)
     138!OMP THREADPRIVATE(tnat, alpha_ideal, conv_flg, pbl_flg, niadv, itr_indice, solsym)
     139
     140#ifdef CPP_StratAer
     141  !=== SPECIFIC TO STRATOSPHERIC AEROSOLS (CK/OB)
     142  INTEGER, SAVE :: nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat
     143!OMP THREADPRIVATE(nbtr_bin, nbtr_sulgas, id_OCS_strat, id_H2SO4_strat, id_SO2_strat, id_BIN01_strat, id_TEST_strat)
     144#endif
     145
    96146CONTAINS
    97147
    98   SUBROUTINE init_infotrac_phy(nqtot_,nqo_,nbtr_,tname_,ttext_,type_trac_,&
    99                                niadv_,conv_flg_,pbl_flg_,solsym_,&
    100                                nqfils_,nqdesc_,nqdesc_tot_,iqfils_,iqpere_,&
    101                                ok_isotopes_,ok_iso_verif_,ok_isotrac_,&
    102                                ok_init_iso_,niso_possibles_,tnat_,&
    103                                alpha_ideal_,use_iso_,iqiso_,iso_num_,&
    104                                iso_indnum_,zone_num_,phase_num_,&
    105                                indnum_fn_num_,index_trac_,&
    106                                niso_,ntraceurs_zone_,ntraciso_&
     148SUBROUTINE init_infotrac_phy(tracers_, isotopes_, type_trac_, solsym_, nbtr_, niadv_, pbl_flg_, conv_flg_)
     149  ! transfer information on tracers from dynamics to physics
     150  USE print_control_mod, ONLY: prt_level, lunout
     151  IMPLICIT NONE
     152  TYPE(tra),        INTENT(IN) ::  tracers_(:)
     153  TYPE(iso),        INTENT(IN) :: isotopes_(:)
     154  CHARACTER(LEN=*), INTENT(IN) :: type_trac_, solsym_(:)
     155  INTEGER,          INTENT(IN) :: nbtr_, niadv_(:), pbl_flg_(:), conv_flg_(:)
     156
     157  CHARACTER(LEN=256) :: modname="init_infotrac_phy"
     158  LOGICAL :: lerr
     159
     160  tracers   = tracers_
     161  isotopes  = isotopes_
     162  type_trac = type_trac_
     163  solsym    = solsym_
     164  nqtot     = SIZE(tracers_)
     165  nbtr      = nbtr_
     166  niadv     = niadv_
     167  nbIso     = SIZE(isotopes_)
     168  pbl_flg  = pbl_flg_
     169  conv_flg = conv_flg_
     170
     171  !=== Specific to water
     172  CALL getKey_init(tracers, isotopes)
     173  IF(.NOT.isoSelect('H2O')) THEN
     174    iH2O = ixIso
     175    lerr = getKey('tnat' ,tnat,        isoName)
     176    lerr = getKey('alpha',alpha_ideal, isoName)
     177    nqo  = isotope%npha
     178  END IF
     179  IF(prt_level > 1) WRITE(lunout,*) TRIM(modname)//": nqtot, nqo, nbtr = ",nqtot, nqo, nbtr
     180  itr_indice = PACK(tracers(:)%itr, MASK = tracers(:)%itr/=0)
     181print*,'66'
     182
     183  !? conv_flg, pbl_flg, solsym
     184  !? isoInit
     185
    107186#ifdef CPP_StratAer
    108                                ,nbtr_bin_,nbtr_sulgas_&
    109                                ,id_OCS_strat_,id_SO2_strat_,id_H2SO4_strat_,id_BIN01_strat_&
     187  IF (type_trac == 'coag') THEN
     188    nbtr_bin=0
     189    nbtr_sulgas=0
     190    DO iq = 1, nqtrue
     191      IF(tracers(iq)%name(1:3)=='BIN') nbtr_bin    = nbtr_bin   +1
     192      IF(tracers(iq)%name(1:3)=='GAS') nbtr_sulgas = nbtr_sulgas+1
     193      SELECT CASE(tracers(iq)%name)
     194        CASE('BIN01');    id_BIN01_strat = iq - nqo; CALL msg('id_BIN01_strat=', id_BIN01_strat)
     195        CASE('GASOCS');   id_OCS_strat   = iq - nqo; CALL msg('id_OCS_strat  =', id_OCS_strat)
     196        CASE('GASSO2');   id_SO2_strat   = iq - nqo; CALL msg('id_SO2_strat  =', id_SO2_strat)
     197        CASE('GASH2SO4'); id_H2SO4_strat = iq - nqo; CALL msg('id_H2SO4_strat=', id_H2SO4_strat)
     198        CASE('GASTEST');  id_TEST_strat  = iq - nqo; CALL msg('id_TEST_strat=' , id_TEST_strat)
     199      END SELECT
     200    END DO
     201    CALL msg('nbtr_bin      =',nbtr_bin)
     202    CALL msg('nbtr_sulgas   =',nbtr_sulgas)
     203  END IF
    110204#endif
    111                                )
    112 
    113     ! transfer information on tracers from dynamics to physics
    114     USE print_control_mod, ONLY: prt_level, lunout
    115     IMPLICIT NONE
    116 
    117     INTEGER,INTENT(IN) :: nqtot_
    118     INTEGER,INTENT(IN) :: nqo_
    119     INTEGER,INTENT(IN) :: nbtr_
    120 #ifdef CPP_StratAer
    121     INTEGER,INTENT(IN) :: nbtr_bin_
    122     INTEGER,INTENT(IN) :: nbtr_sulgas_
    123     INTEGER,INTENT(IN) :: id_OCS_strat_
    124     INTEGER,INTENT(IN) :: id_SO2_strat_
    125     INTEGER,INTENT(IN) :: id_H2SO4_strat_
    126     INTEGER,INTENT(IN) :: id_BIN01_strat_
    127 #endif
    128     CHARACTER(len=20),INTENT(IN) :: tname_(nqtot_) ! tracer short name for restart and diagnostics
    129     CHARACTER(len=23),INTENT(IN) :: ttext_(nqtot_) ! tracer long name for diagnostics
    130     CHARACTER(len=4),INTENT(IN) :: type_trac_
    131     INTEGER,INTENT(IN) :: niadv_ (nqtot_) ! equivalent dyn / physique
    132     INTEGER,INTENT(IN) :: conv_flg_(nbtr_)
    133     INTEGER,INTENT(IN) :: pbl_flg_(nbtr_)
    134     CHARACTER(len=8),INTENT(IN) :: solsym_(nbtr_)
    135     ! Isotopes:
    136     INTEGER,INTENT(IN) :: nqfils_(nqtot_)
    137     INTEGER,INTENT(IN) :: nqdesc_(nqtot_)
    138     INTEGER,INTENT(IN) :: nqdesc_tot_
    139     INTEGER,INTENT(IN) :: iqfils_(nqtot_,nqtot_)
    140     INTEGER,INTENT(IN) :: iqpere_(nqtot_)
    141     LOGICAL,INTENT(IN) :: ok_isotopes_
    142     LOGICAL,INTENT(IN) :: ok_iso_verif_
    143     LOGICAL,INTENT(IN) :: ok_isotrac_
    144     LOGICAL,INTENT(IN) :: ok_init_iso_
    145     INTEGER,INTENT(IN) :: niso_possibles_
    146     REAL,INTENT(IN) :: tnat_(niso_possibles_)
    147     REAL,INTENT(IN) :: alpha_ideal_(niso_possibles_)
    148     LOGICAL,INTENT(IN) :: use_iso_(niso_possibles_)
    149     INTEGER,INTENT(IN) :: iqiso_(ntraciso_,nqo_)
    150     INTEGER,INTENT(IN) :: iso_num_(nqtot_)
    151     INTEGER,INTENT(IN) :: iso_indnum_(nqtot_)
    152     INTEGER,INTENT(IN) :: zone_num_(nqtot_)
    153     INTEGER,INTENT(IN) :: phase_num_(nqtot_)
    154     INTEGER,INTENT(IN) :: indnum_fn_num_(niso_possibles_)
    155     INTEGER,INTENT(IN) :: index_trac_(ntraceurs_zone_,niso_)
    156     INTEGER,INTENT(IN) :: niso_
    157     INTEGER,INTENT(IN) :: ntraceurs_zone_
    158     INTEGER,INTENT(IN) :: ntraciso_
    159 
    160     CHARACTER(LEN=30) :: modname="init_infotrac_phy"
    161 
    162     nqtot=nqtot_
    163     nqo=nqo_
    164     nbtr=nbtr_
    165 #ifdef CPP_StratAer
    166     nbtr_bin=nbtr_bin_
    167     nbtr_sulgas=nbtr_sulgas_
    168     id_OCS_strat=id_OCS_strat_
    169     id_SO2_strat=id_SO2_strat_
    170     id_H2SO4_strat=id_H2SO4_strat_
    171     id_BIN01_strat=id_BIN01_strat_
    172 #endif
    173     ALLOCATE(tname(nqtot))
    174     tname(:) = tname_(:)
    175     ALLOCATE(ttext(nqtot))
    176     ttext(:) = ttext_(:)
    177     type_trac = type_trac_
    178     ALLOCATE(niadv(nqtot))
    179     niadv(:)=niadv_(:)
    180     ALLOCATE(conv_flg(nbtr))
    181     conv_flg(:)=conv_flg_(:)
    182     ALLOCATE(pbl_flg(nbtr))
    183     pbl_flg(:)=pbl_flg_(:)
    184     ALLOCATE(solsym(nbtr))
    185     solsym(:)=solsym_(:)
    186  
    187     IF(prt_level.ge.1) THEN
    188       write(lunout,*) TRIM(modname)//": nqtot,nqo,nbtr",nqtot,nqo,nbtr
    189     ENDIF
    190    
    191     ! Isotopes:
    192    
    193     ! First check that the "niso_possibles" has the correct value
    194     IF (niso_possibles.ne.niso_possibles_) THEN
    195       CALL abort_physic(modname,&
    196            "wrong value for parameter niso_possibles in infotrac_phy",1)
    197     ENDIF
    198    
    199     ok_isotopes=ok_isotopes_
    200     ok_iso_verif=ok_iso_verif_
    201     ok_isotrac=ok_isotrac_
    202     ok_init_iso=ok_init_iso_
    203    
    204     niso=niso_
    205     ntraceurs_zone=ntraceurs_zone_
    206     ntraciso=ntraciso_
    207    
    208     IF (ok_isotopes) THEN
    209       ALLOCATE(nqfils(nqtot))
    210       nqfils(:)=nqfils_(:)
    211       ALLOCATE(nqdesc(nqtot))
    212       nqdesc(:)=nqdesc_(:)
    213       nqdesc_tot=nqdesc_tot_
    214       ALLOCATE(iqfils(nqtot,nqtot))
    215       iqfils(:,:)=iqfils_(:,:)
    216       ALLOCATE(iqpere(nqtot))
    217       iqpere(:)=iqpere_(:)
    218    
    219       tnat(:)=tnat_(:)
    220       alpha_ideal(:)=alpha_ideal_(:)
    221       use_iso(:)=use_iso_(:)
    222    
    223       ALLOCATE(iqiso(ntraciso,nqo))
    224       iqiso(:,:)=iqiso_(:,:)
    225       ALLOCATE(iso_num(nqtot))
    226       iso_num(:)=iso_num_(:)
    227       ALLOCATE(iso_indnum(nqtot))
    228       iso_indnum(:)=iso_indnum_(:)
    229       ALLOCATE(zone_num(nqtot))
    230       zone_num(:)=zone_num_(:)
    231       ALLOCATE(phase_num(nqtot))
    232       phase_num(:)=phase_num_(:)
    233      
    234       indnum_fn_num(:)=indnum_fn_num_(:)
    235      
    236       ALLOCATE(index_trac(ntraceurs_zone,niso))
    237       index_trac(:,:)=index_trac_(:,:)
    238     ENDIF ! of IF(ok_isotopes)
    239  
    240   END SUBROUTINE init_infotrac_phy
     205
     206END SUBROUTINE init_infotrac_phy
     207
     208
     209!==============================================================================================================================
     210!=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED
     211!     Singe generic "isoSelect" routine, using the predefined parent index (fast version) or its name (first time).
     212!==============================================================================================================================
     213LOGICAL FUNCTION isoSelectByName(iName) RESULT(lerr)
     214  CHARACTER(LEN=*), INTENT(IN)  :: iName
     215  INTEGER :: iIso
     216  iIso = strIdx(isotopes(:)%prnt, iName)
     217  IF(test(fmsg(iIso == 0,'no isotope family named "'//TRIM(iName)//'"'),lerr)) RETURN
     218  IF(isoSelectByIndex(iIso)) RETURN
     219END FUNCTION isoSelectByName
     220!==============================================================================================================================
     221LOGICAL FUNCTION isoSelectByIndex(iIso) RESULT(lerr)
     222  INTEGER, INTENT(IN) :: iIso
     223  lerr = .FALSE.
     224  IF(iIso == ixIso) RETURN                                      !--- Nothing to do if the index is already OK
     225  IF(test(fmsg(iIso<=0 .OR. iIso>=nbIso,'Inconsistent isotopes family index '//TRIM(int2str(iIso))),lerr)) RETURN
     226  ixIso = iIso                                                  !--- Update currently selected family index
     227  isotope => isotopes(ixIso)                                    !--- Select corresponding component
     228  !--- VARIOUS ALIASES
     229  isoKeys => isotope%keys; niso = isotope%niso
     230  isoName => isotope%trac; nitr = isotope%nitr; isoCheck => isotope%check
     231  isoZone => isotope%zone; nzon = isotope%nzon; iZonIso  => isotope%iZonIso
     232  isoPhas => isotope%phas; npha = isotope%npha; iTraPha  => isotope%iTraPha
     233END FUNCTION isoSelectByIndex
     234!==============================================================================================================================
    241235
    242236END MODULE infotrac_phy

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/phyetat0.F90

    r3851 r3852  
    2323  USE geometry_mod, ONLY : longitude_deg, latitude_deg
    2424  USE iostart, ONLY : close_startphy, get_field, get_var, open_startphy
    25   USE infotrac_phy, only: nbtr, nqo, type_trac, tname, niadv
     25  USE infotrac_phy, only: nbtr, nqo, type_trac, tracers, niadv
    2626  USE traclmdz_mod,    ONLY : traclmdz_from_restart
    2727  USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl, co2_send
    … …  
    443443!!        iiq=niadv(it+2)                                                           ! jyg
    444444        iiq=niadv(it+nqo)                                                           ! jyg
    445         found=phyetat0_get(1,trs(:,it),"trs_"//tname(iiq), &
    446               "Surf trac"//tname(iiq),0.)
     445        found=phyetat0_get(1,trs(:,it),"trs_"//tracers(iiq)%name, &
     446              "Surf trac"//tracers(iiq)%name,0.)
    447447     ENDDO
    448448     CALL traclmdz_from_restart(trs)

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/phyredem.F90

    r3851 r3852  
    3333  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
    3434  USE traclmdz_mod, ONLY : traclmdz_to_restart
    35   USE infotrac_phy, ONLY: type_trac, niadv, tname, nbtr, nqo
     35  USE infotrac_phy, ONLY: type_trac, niadv, tracers, nbtr, nqo
    3636  USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
    3737  USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic, epsfra
    … …  
    311311!!        iiq=niadv(it+2)                                                           ! jyg
    312312          iiq=niadv(it+nqo)                                                           ! jyg
    313           CALL put_field(pass,"trs_"//tname(iiq), "", trs(:, it))
     313          CALL put_field(pass,"trs_"//tracers(iiq)%name, "", trs(:, it))
    314314       END DO
    315315       IF (carbon_cycle_cpl) THEN

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/phys_output_mod.F90

    r3851 r3852  
    3535    USE iophy
    3636    USE dimphy
    37     USE infotrac_phy, ONLY: nqtot, nqo, niadv, tname, ttext, type_trac
     37    USE infotrac_phy, ONLY: nqtot, nqo, niadv, tracers, type_trac
    3838    USE ioipsl
    3939    USE phys_cal_mod, only : hour, calend
    … …  
    143143    REAL, DIMENSION(NSW,2)          :: spbnds_sun !bounds of spectband
    144144
     145    CHARACTER(LEN=256), POINTER :: tname(:), ttext(:)
     146
    145147    WRITE(lunout,*) 'Debut phys_output_mod.F90'
     148    tname => tracers(:)%name
     149    ttext => tracers(:)%lnam
     150
    146151    ! Initialisations (Valeurs par defaut
    147152

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/phys_output_write_mod.F90

    r3851 r3852  
    363363    USE pbl_surface_mod, ONLY: snow
    364364    USE indice_sol_mod, ONLY: nbsrf
    365     USE infotrac_phy, ONLY: nqtot, nqo, type_trac, tname, niadv
     365    USE infotrac_phy, ONLY: nqtot, nqo, type_trac, tracers, niadv
    366366    USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg
    367367    USE surface_data, ONLY: type_ocean, version_ocean, ok_veget, landice_opt
    … …  
    449449    REAL,DIMENSION(klon,klev) :: z, dz
    450450    REAL,DIMENSION(klon)      :: zrho, zt
     451    CHARACTER(LEN=256), POINTER :: tname(:)
     452
     453    tname => tracers(:)%name
    451454
    452455    ! On calcul le nouveau tau:

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/traclmdz_mod.F90

    r3581 r3852  
    6767   
    6868    USE dimphy
    69     USE infotrac_phy
     69    USE infotrac_phy, ONLY: nbtr
    7070   
    7171    ! Input argument
    … …  
    8989    ! Initialization of the tracers should be done here only for those not found in the restart file.
    9090    USE dimphy
    91     USE infotrac_phy
     91    USE infotrac_phy, ONLY: tracers, nqo, nbtr, niadv, pbl_flg, conv_flg
    9292    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
    9393    USE press_coefoz_m, ONLY: press_coefoz
    … …  
    175175!!       iiq=niadv(it+2)                                                            ! jyg
    176176       iiq=niadv(it+nqo)                                                            ! jyg
    177        IF ( tname(iiq) == "RN" ) THEN                                               
    178           id_rn=it ! radon
    179        ELSE IF ( tname(iiq) == "PB") THEN
    180           id_pb=it ! plomb
     177       !-----------------------------------------------------------------------
     178       SELECT CASE(tracers(iiq)%name)
     179       !-----------------------------------------------------------------------
     180         CASE("RN"); id_rn=it ! radon
     181       !-----------------------------------------------------------------------
     182         CASE("PB"); id_pb=it ! plomb
    181183! RomP >>> profil initial de PB210
    182184     open (ilesfil2,file='prof.pb210',status='old',iostat=irr2)
    … …  
    198200     ENDIF
    199201! RomP <<<
    200        ELSE IF ( tname(iiq) == "Aga" .OR. tname(iiq) == "AGA" ) THEN
    201           ! Age of stratospheric air
    202           id_aga=it
     202       !-----------------------------------------------------------------------
     203         CASE("Aga","AGA");           id_aga   = it ! Age of stratospheric air
    203204          radio(id_aga) = .FALSE.
    204205          aerosol(id_aga) = .FALSE.
    … …  
    213214             lev_1p5km=klev/2
    214215          END IF
    215        ELSE IF ( tname(iiq) == "BE" .OR. tname(iiq) == "Be" .OR.  &
    216             tname(iiq) == "BE7" .OR. tname(iiq) == "Be7" ) THEN 
    217           ! Recherche du Beryllium 7
    218           id_be=it
     216       !-----------------------------------------------------------------------
     217         CASE("BE","Be","BE7","Be7"); id_be    = it ! Recherche du Beryllium 7
    219218          ALLOCATE( srcbe(klon,klev) )
    220219          radio(id_be) = .TRUE.
    … …  
    243242     ENDIF
    244243! RomP <<<
    245        ELSE IF (tname(iiq)=="O3" .OR. tname(iiq)=="o3") THEN
    246           ! Recherche de l'ozone : parametrization de la chimie par Cariolle
    247           id_o3=it
    248           CALL alloc_coefoz   ! allocate ozone coefficients
    249           CALL press_coefoz   ! read input pressure levels
    250        ELSE IF ( tname(iiq) == "pcsat" .OR. tname(iiq) == "Pcsat" ) THEN
    251           id_pcsat=it
    252        ELSE IF ( tname(iiq) == "pcocsat" .OR. tname(iiq) == "Pcocsat" ) THEN
    253           id_pcocsat=it
    254        ELSE IF ( tname(iiq) == "pcq" .OR. tname(iiq) == "Pcq" ) THEN
    255           id_pcq=it
    256        ELSE IF ( tname(iiq) == "pcs0" .OR. tname(iiq) == "Pcs0" ) THEN
    257           id_pcs0=it
    258           conv_flg(it)=0 ! No transport by convection for this tracer
    259        ELSE IF ( tname(iiq) == "pcos0" .OR. tname(iiq) == "Pcos0" ) THEN
    260           id_pcos0=it
    261           conv_flg(it)=0 ! No transport by convection for this tracer
    262        ELSE IF ( tname(iiq) == "pcq0" .OR. tname(iiq) == "Pcq0" ) THEN
    263           id_pcq0=it
    264           conv_flg(it)=0 ! No transport by convection for this tracer
    265        ELSE
    266           WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tname(iiq))
    267        END IF
     244       !-----------------------------------------------------------------------
     245         CASE("O3","o3");           id_o3      = it
     246           ! Recherche de l'ozone : parametrization de la chimie par Cariolle
     247           CALL alloc_coefoz   ! allocate ozone coefficients
     248           CALL press_coefoz   ! read input pressure levels
     249       !-----------------------------------------------------------------------
     250         CASE("pcsat"  ,"Pcsat");   id_pcsat   = it
     251       !-----------------------------------------------------------------------
     252         CASE("pcocsat","Pcocsat"); id_pcocsat = it
     253       !-----------------------------------------------------------------------
     254         CASE("pcq"    ,"Pcq");     id_pcq     = it
     255       !-----------------------------------------------------------------------
     256         CASE("pcs0"   ,"Pcs0");    id_pcs0    = it
     257           conv_flg(it)=0 ! No transport by convection for this tracer
     258       !-----------------------------------------------------------------------
     259         CASE("pcos0"  ,"Pcos0");   id_pcos0   = it
     260           conv_flg(it)=0 ! No transport by convection for this tracer
     261       !-----------------------------------------------------------------------
     262         CASE("pcq0"   ,"Pcq0");    id_pcq0    = it
     263           conv_flg(it)=0 ! No transport by convection for this tracer
     264       !-----------------------------------------------------------------------
     265         CASE DEFAULT
     266           WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tracers(iiq)%name)
     267       !-----------------------------------------------------------------------
     268       END SELECT
     269       !-----------------------------------------------------------------------
    268270    END DO
    269271
    … …  
    309311       IF (zero) THEN
    310312          ! The tracer was not found in restart file or it was equal zero everywhere.
    311           WRITE(lunout,*) "The tracer ",trim(tname(iiq))," will be initialized"
     313          WRITE(lunout,*) "The tracer ",trim(tracers(iiq)%name)," will be initialized"
    312314          IF (it==id_pcsat .OR. it==id_pcq .OR. &
    313315               it==id_pcs0 .OR. it==id_pcq0) THEN
Note: See TracChangeset for help on using the changeset viewer.