Changeset 5190 for LMDZ6/trunk/libf
- Timestamp:
- Sep 15, 2024, 10:38:32 AM (10 months ago)
- Location:
- LMDZ6/trunk/libf
- Files:
-
- 1 deleted
- 21 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/dyn3d/check_isotopes.F90
r5183 r5190 2 2 USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str 3 3 USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & 4 ntiso, iH2O, nzone, tracers, isoName, itZonIso 5 USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO 6 USE ioipsl_getincom, ONLY: getin 4 ntiso, iH2O, nzone, tracers, isoName, itZonIso, getKey 7 5 IMPLICIT NONE 8 6 include "dimensions.h" … … 22 20 deltaDmin =-999.0, & 23 21 ridicule = 1e-12 24 INTEGER, SAVE :: iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO 25 LOGICAL, SAVE :: ltnat1, first=.TRUE. 22 INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, & 23 iso_O17, iso_HTO 24 LOGICAL, SAVE :: first=.TRUE. 25 LOGICAL, PARAMETER :: tnat1=.TRUE. 26 26 27 27 modname='check_isotopes' … … 30 30 IF(niso == 0) RETURN !--- No isotopes => finished 31 31 IF(first) THEN 32 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1) 33 ALLOCATE(tnat(niso)) 34 iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O 35 iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O 36 iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O 37 iso_HDO = strIdx(isoName,'HDO'); IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO 38 iso_HTO = strIdx(isoName,'HTO'); IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO 39 IF(ltnat1) tnat(:) = 1. 32 iso_eau = strIdx(isoName,'H216O') 33 iso_HDO = strIdx(isoName,'HDO') 34 iso_O18 = strIdx(isoName,'H218O') 35 iso_O17 = strIdx(isoName,'H217O') 36 iso_HTO = strIdx(isoName,'HTO') 37 if (tnat1) then 38 tnat(:)=1.0 39 else 40 IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1) 41 endif 40 42 first = .FALSE. 41 43 END IF -
LMDZ6/trunk/libf/dyn3d/dynetat0.F90
r5183 r5190 6 6 ! Purpose: Initial state reading. 7 7 !------------------------------------------------------------------------------- 8 USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, & 9 new2oldH2O, newHNO3, oldHNO3 8 USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName 10 9 USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str 11 10 USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQ_VARID, & 12 11 NF90_CLOSE, NF90_GET_VAR, NF90_NoErr 12 USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey 13 13 USE control_mod, ONLY: planet_type 14 14 USE assert_eq_m, ONLY: assert_eq … … 19 19 USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time 20 20 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 21 #ifdef CPP_IOIPSL22 USE IOIPSL, ONLY: getin23 #else24 USE ioipsl_getincom, ONLY: getin25 #endif26 USE iso_params_mod ! tnat_* and alpha_ideal_*27 21 28 22 IMPLICIT NONE … … 48 42 INTEGER :: iq, fID, vID, idecal, iqParent, iName, iZone, iPhase 49 43 REAL :: time, tnat, alpha_ideal, tab_cntrl(length) !--- RUN PARAMS TABLE 50 LOGICAL :: lSkip, ll, ltnat1 44 LOGICAL :: lSkip, ll 45 LOGICAL,PARAMETER :: tnat1=.TRUE. 51 46 !------------------------------------------------------------------------------- 52 47 modname="dynetat0" … … 121 116 var="temps" 122 117 IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN 123 CALL msg(' Missing field <temps> ; trying with <Time>', modname)118 CALL msg('missing field <temps> ; trying with <Time>', modname) 124 119 var="Time" 125 120 CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var) … … 138 133 ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr !--- DETECT OLD REPRO start.nc FILE 139 134 #endif 140 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)141 135 DO iq=1,nqtot 142 136 var = tracers(iq)%name … … 154 148 !-------------------------------------------------------------------------------------------------------------------------- 155 149 ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN !=== TRY WITH ALTERNATE NAME 156 CALL msg(' Missing tracer <'//TRIM(var)//'>=> initialized to <'//TRIM(oldVar)//'>', modname)150 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname) 157 151 CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",oldVar) 158 152 !-------------------------------------------------------------------------------------------------------------------------- … … 162 156 iqParent = tracers(iq)%iqParent 163 157 IF(tracers(iq)%iso_iZone == 0) THEN 164 IF(ltnat1) THEN 165 tnat = 1.0 166 alpha_ideal = 1.0 167 CALL msg(' !!! Beware: alpha_ideal put to 1 !!!', modname) 168 ELSE 169 SELECT CASE(isoName(iName)) 170 CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O 171 CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O 172 CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O 173 CASE('HDO'); tnat = tnat_HDO; alpha_ideal = alpha_ideal_HDO 174 CASE('HTO'); tnat = tnat_HTO; alpha_ideal = alpha_ideal_HTO 175 CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1) 176 END SELECT 177 END IF 178 CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname) 158 if (tnat1) then 159 tnat=1.0 160 alpha_ideal=1.0 161 write(*,*) 'attention dans dynetat0: les alpha_ideal sont a 1' 162 else 163 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) & 164 CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1) 165 endif 166 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname) 179 167 q(:,:,:,iq) = q(:,:,:,iqParent)*tnat*(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal-1.) 180 168 ELSE 181 CALL msg(' Missing tracer <'//TRIM(var)//'>=> initialized to its parent isotope concentration.', modname)169 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to its parent isotope concentration.', modname) 182 170 ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à 183 171 ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme … … 193 181 !-------------------------------------------------------------------------------------------------------------------------- 194 182 ELSE !=== MISSING: SET TO 0 195 CALL msg(' Missing tracer <'//TRIM(var)//'>=> initialized to zero', modname)183 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to zero', modname) 196 184 q(:,:,:,iq)=0. 197 185 !-------------------------------------------------------------------------------------------------------------------------- -
LMDZ6/trunk/libf/dyn3d/iniacademic.F90
r5183 r5190 5 5 6 6 USE filtreg_mod, ONLY: inifilr 7 USE infotrac, ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName , addPhase7 USE infotrac, ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName 8 8 USE control_mod, ONLY: day_step,planet_type 9 9 use exner_hyb_m, only: exner_hyb … … 21 21 USE temps_mod, ONLY: annee_ref, day_ini, day_ref 22 22 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 23 USE readTracFiles_mod, ONLY: addPhase 23 24 use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID 24 25 use netcdf, only : NF90_CLOSE, NF90_GET_VAR 25 USE iso_params_mod ! tnat_* and alpha_ideal_*26 26 27 27 … … 80 80 81 81 REAL zdtvr, tnat, alpha_ideal 82 LOGICAL :: ltnat182 LOGICAL,PARAMETER :: tnat1=.true. 83 83 84 84 character(len=*),parameter :: modname="iniacademic" … … 309 309 ! bulk initialization of tracers 310 310 if (planet_type=="earth") then 311 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)312 311 ! Earth: first two tracers will be water 313 312 do iq=1,nqtot … … 323 322 iqParent = tracers(iq)%iqParent 324 323 IF(tracers(iq)%iso_iZone == 0) THEN 325 IF(ltnat1) THEN 326 tnat = 1.0 327 alpha_ideal = 1.0 328 WRITE(lunout, *)'In '//TRIM(modname)//': !!! Beware: alpha_ideal put to 1 !!!' 329 ELSE 330 SELECT CASE(isoName(iName)) 331 CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O 332 CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O 333 CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O 334 CASE('HDO'); tnat = tnat_HDO; alpha_ideal = alpha_ideal_HDO 335 CASE('HTO'); tnat = tnat_HTO; alpha_ideal = alpha_ideal_HTO 336 CASE DEFAULT 337 CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1) 338 END SELECT 339 END IF 324 if (tnat1) then 325 tnat=1.0 326 alpha_ideal=1.0 327 write(*,*) 'Attention dans iniacademic: alpha_ideal=1' 328 else 329 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) & 330 CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1) 331 endif 340 332 q(:,:,iq) = q(:,:,iqParent)*tnat*(q(:,:,iqParent)/30.e-3)**(alpha_ideal-1.) 341 333 ELSE !IF(tracers(iq)%iso_iZone == 0) THEN -
LMDZ6/trunk/libf/dyn3d/qminimum.F
r5183 r5190 4 4 SUBROUTINE qminimum( q,nqtot,deltap ) 5 5 6 USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase6 USE infotrac, ONLY: niso, ntiso,iqIsoPha, tracers 7 7 USE strings_mod, ONLY: strIdx 8 USE readTracFiles_mod, ONLY: addPhase 8 9 IMPLICIT none 9 10 c -
LMDZ6/trunk/libf/dyn3d_common/infotrac.F90
r5183 r5190 3 3 MODULE infotrac 4 4 5 USE strings_mod, ONLY: msg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strCount, strIdx 6 USE readTracFiles_mod, ONLY: readTracersFiles, maxTableWidth, tisot=>isot_type, addPhase, addKey, iH2O, & 7 indexUpdate, keys_type, testTracersFiles, processIsotopes, trac=>tracers, delPhase, getKey, tran0 8 USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3 9 5 USE strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse 6 USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, & 7 delPhase, niso, getKey, isot_type, processIsotopes, isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, & 8 addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate, iqWIsoPha, nbIso, ntiso, isoName, isoCheck 10 9 IMPLICIT NONE 11 10 … … 17 16 PUBLIC :: nqtot, nbtr, nqo, nqCO2, nqtottr !--- Main dimensions 18 17 PUBLIC :: conv_flg, pbl_flg !--- Convection & boundary layer activation keys 19 PUBLIC :: new2oldH2O, newHNO3, oldHNO3 !--- For backwards compatibility in dynetat020 PUBLIC :: addPhase, delPhase !--- Add/remove the phase from the name of a tracer21 18 22 19 !=== FOR ISOTOPES: General 23 20 PUBLIC :: isot_type, nbIso !--- Derived type, full isotopes families database + nb of families 24 PUBLIC :: isoSelect, ixIso , isoFamilies !--- Isotopes families selection tool + selected index + list21 PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index 25 22 !=== FOR ISOTOPES: Specific to water 26 PUBLIC :: iH2O !--- Value of "ixIso" for "H2O" isotopes class23 PUBLIC :: iH2O !--- H2O isotopes class index 27 24 PUBLIC :: min_qParent, min_qMass, min_ratio !--- Min. values for various isotopic quantities 28 25 !=== FOR ISOTOPES: Depending on the selected isotopes family 29 PUBLIC :: isotope !--- Selected isotopes database (argument ofgetKey)30 PUBLIC :: iso Keys, isoName, isoZone, isoPhas !--- Isotopes keys & names,tagging zones names, phases31 PUBLIC :: niso, ntiso, nzone, nphas !--- Number of " "32 PUBLIC :: itZonIso !--- i ndex "it" in "isoName(1:niso)" = f(tagging idx, isotope idx)33 PUBLIC :: iqIsoPha !--- i ndex "iq" in "qx" = f(isotope idx, phase idx)26 PUBLIC :: isotope, isoKeys !--- Selected isotopes database + associated keys (cf. getKey) 27 PUBLIC :: isoName, isoZone, isoPhas !--- Isotopes and tagging zones names, phases 28 PUBLIC :: niso, nzone, nphas, ntiso !--- " " numbers + isotopes & tagging tracers number 29 PUBLIC :: itZonIso !--- idx "it" (in "isoName(1:niso)") = function(tagging idx, isotope idx) 30 PUBLIC :: iqIsoPha !--- idx "iq" (in "qx") = function(isotope idx, phase idx) + aliases 34 31 PUBLIC :: isoCheck !--- Run isotopes checking routines 35 32 !=== FOR BOTH TRACERS AND ISOTOPES … … 39 36 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 40 37 ! | water in different | water tagging | water isotopes | other tracers | additional tracers moments | 41 ! | phases: H2O_[gls rb]| isotopes | | | for higher order schemes |38 ! | phases: H2O_[gls] | isotopes | | | for higher order schemes | 42 39 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 43 40 ! | | | | | | … … 53 50 ! |-----------------------------------------------------------------------------------------------------------| 54 51 ! NOTES FOR THIS TABLE: 55 ! * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)% name== 'H2O'),52 ! * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)%parent == 'H2O'), 56 53 ! since water is so far the sole tracers family, except passive CO2, removed from the main tracers table. 57 54 ! * For water, "nqo" is equal to the more general field "isotopes(ip)%nphas". 58 55 ! * "niso", "nzone", "ntiso", "nphas" are defined for other isotopic tracers families, if any. 59 ! * If you deal with an isotopes family other than "H2O" ("Sulf" in the example), a good practice is to keep 60 ! track of the isotopes class (of its index) before switching to it at the beginning of the dedicated code: 61 ! - first time (use selection by name and compute the corresponding index iSulf) : 62 ! i0=ixIso; IF(.NOT.isoSelect('Sulf')) CALL abort_gcm("Can't select isotopes class", modname, 1); iS=ixIso 63 ! - next times (use selection by index - "iS" has been computed at first call): 64 ! i0=ixIso; IF(.NOT.isoSelect(iS)) CALL abort_gcm("Can't select isotopes class", modname, 1) 65 ! and to switch back to the original category when you're done with "Sulf": 66 ! IF(.NOT.isoSelect(i0)) CALL abort_gcm("Can't select isotopes class", modname, 1) 67 ! to restore the original isotopes category (before dealing with "Sulf" (most of the time "H2O"). 68 ! 69 !=== LOCAL DERIVED TYPE "trac_type" EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot) 56 ! 57 !=== DERIVED TYPE EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot) 70 58 ! Each entry is accessible using "%" sign. 71 59 ! |-------------+------------------------------------------------------+-------------+------------------------+ … … 73 61 ! |-------------+------------------------------------------------------+-------------+------------------------+ 74 62 ! | name | Name (short) | tname | | 75 ! | keys | key/val pairs accessible with "getKey" routine | / | |76 63 ! | gen0Name | Name of the 1st generation ancestor | / | | 77 64 ! | parent | Name of the parent | / | | 78 65 ! | longName | Long name (with adv. scheme suffix) for outputs | ttext | | 79 66 ! | type | Type (so far: tracer or tag) | / | tracer,tag | 80 ! | phase | Phases list ("g"as / "l"iquid / "s"olid | | [g|l|s|r|b] | 81 ! | | "r"(cloud) / "b"lowing) | / | | 67 ! | phase | Phases list ("g"as / "l"iquid / "s"olid) | / | [g][l][s] | 82 68 ! | component | Name(s) of the merged/cumulated section(s) | / | coma-separated names | 83 69 ! | iGeneration | Generation (>=1) | / | | … … 86 72 ! | nqDescen | Number of the descendants (all generations) | nqdesc | 1:nqtot | 87 73 ! | nqChildren | Number of childs (1st generation only) | nqfils | 1:nqtot | 74 ! | keys | key/val pairs accessible with "getKey" routine | / | | 88 75 ! | iadv | Advection scheme number | iadv | 1,2,10-20(exc.15,19),30| 76 ! | isAdvected | advected tracers flag (.TRUE. if iadv >= 0) | / | nqtrue .TRUE. values | 77 ! | isInPhysics | tracers not extracted from the main table in physics | / | nqtottr .TRUE. values | 89 78 ! | iso_iGroup | Isotopes group index in isotopes(:) | / | 1:nbIso | 90 79 ! | iso_iName | Isotope name index in isotopes(iso_iGroup)%trac(:) | iso_indnum | 1:niso | … … 98 87 ! | entry | length | Meaning | Former name | Possible values | 99 88 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 100 ! | name | Name of the isotopes class (family)| | |89 ! | parent | Parent tracer (isotopes family name) | | | 101 90 ! | keys | niso | Isotopes keys/values pairs list + number | | | 102 91 ! | trac | ntiso | Isotopes + tagging tracers list + number | / | ntraciso | | 103 92 ! | zone | nzone | Geographic tagging zones list + number | / | ntraceurs_zone | | 104 ! | phase | nphas | Phases list + number | | [g |l|s|r|b] 1:5|93 ! | phase | nphas | Phases list + number | | [g][l][s], 1:3 | 105 94 ! | iqIsoPha | Index in "qx" = f(name(1:ntiso)),phas) | iqiso | 1:nqtot | 106 95 ! | itZonIso | Index in "trac(1:ntiso)"= f(zone, name(1:niso)) | index_trac | 1:ntiso | 107 96 ! +-----------------+--------------------------------------------------+--------------------+-----------------+ 108 97 109 !------------------------------------------------------------------------------------------------------------------------------110 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name"111 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer112 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector (general container)113 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name114 CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name115 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix)116 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag')117 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid)118 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca)119 INTEGER :: iGeneration = -1 !--- Generation number (>=0)120 INTEGER :: iqParent = 0 !--- Parent index121 INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order)122 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations)123 INTEGER :: nqChildren = 0 !--- Number of children (first generation)124 INTEGER :: iadv = 10 !--- Advection scheme used125 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:)126 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:)127 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:)128 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase129 END TYPE trac_type130 !------------------------------------------------------------------------------------------------------------------------------131 TYPE :: isot_type !=== TYPE FOR THE ISOTOPES FAMILY DESCENDING ON TRACER "name"132 CHARACTER(LEN=maxlen) :: name !--- Isotopes family name (ex: H2O)133 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso)134 LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering135 CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso)136 CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone)137 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g|l|s|r|b] (length: nphas)138 INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers139 INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers140 INTEGER :: nzone = 0 !--- Number of geographic tagging zones141 INTEGER :: nphas = 0 !--- Number of phases142 INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f( name(1:ntiso) ,phas)143 INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone,name(1:niso))144 END TYPE isot_type145 !------------------------------------------------------------------------------------------------------------------------------146 INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect147 !------------------------------------------------------------------------------------------------------------------------------148 149 !=== THRESHOLDS FOR WATER150 98 REAL, PARAMETER :: min_qParent = 1.e-30, min_qMass = 1.e-18, min_ratio = 1.e-16 ! MVals et CRisi 151 99 152 100 !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES 153 INTEGER, SAVE :: nqtot, &!--- Tracers nb in dynamics (incl. higher moments + H2O)154 nbtr, &!--- Tracers nb in physics (excl. higher moments + H2O)155 nqo, &!--- Number of water phases101 INTEGER, SAVE :: nqtot, & !--- Tracers nb in dynamics (incl. higher moments + H2O) 102 nbtr, & !--- Tracers nb in physics (excl. higher moments + H2O) 103 nqo, & !--- Number of water phases 156 104 nqtottr, & !--- Number of tracers passed to phytrac (TO BE DELETED ?) 157 105 nqCO2 !--- Number of tracers of CO2 (ThL) 158 CHARACTER(LEN=maxlen), SAVE :: type_trac !--- Keyword for tracers type(s) 159 160 !=== NUMBER AND LIST OF DEFINED ISOTOPES FAMILIES 161 INTEGER, SAVE :: nbIso !--- Number of defined isotopes classes 162 CHARACTER(LEN=maxlen), SAVE, ALLOCATABLE :: isoFamilies(:) !--- Generation 0 tracer name for each isotopes family (nbIso) 163 164 !=== QUANTITIES RELATED TO THE CURRENTLY SELECTED ISOTOPES CLASS (USUALLY H2O) 165 TYPE(isot_type), SAVE, POINTER :: isotope !--- Selected isotopes database (=isotopes(ixIso)) 166 TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- Database to get isotopes keys using "getKey" (niso) 167 CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- Isotopes list including tagging tracers, no phase (ntiso) 168 isoZone(:), & !--- Geographic tagging zones list (nzone) 169 isoPhas !--- Used phases names ([g|l|s|r|b]) (nphas) 170 INTEGER, SAVE, POINTER :: itZonIso(:,:), & !--- Idx "it" in isoName(1:niso) = f(tagging idx, isotope idx) 171 iqIsoPha(:,:) !--- Idx "iq" in qx = f(isotope idx, phase idx) 172 INTEGER, SAVE :: ixIso, & !--- Idx in "isoFamilies" of currently selectd class 173 niso, & !--- Number of isotopes 174 ntiso, & !--- Number of isotopes + tagging tracers 175 nzone, & !--- Number of tagging zones 176 nphas !--- Number of phases 177 LOGICAL, SAVE :: isoCheck !--- Isotopes checking routines triggering flag 106 CHARACTER(LEN=maxlen), SAVE :: type_trac !--- Keyword for tracers type 178 107 179 108 !=== VARIABLES FOR INCA 180 INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: & 181 conv_flg, pbl_flg !--- Convection / boundary layer activation (nbtr) 182 183 !=== TRACERS/ISOTOPES DESCRIPTORS: EFFECTIVE STORAGE (LOCAL DERIVED TYPES) 184 TYPE(trac_type), SAVE, ALLOCATABLE, TARGET :: tracers(:) 185 TYPE(isot_type), SAVE, ALLOCATABLE, TARGET :: isotopes(:) 109 INTEGER, SAVE, ALLOCATABLE :: conv_flg(:), & !--- Convection activation ; needed for INCA (nbtr) 110 pbl_flg(:) !--- Boundary layer activation ; needed for INCA (nbtr) 186 111 187 112 CONTAINS … … 189 114 SUBROUTINE init_infotrac 190 115 USE control_mod, ONLY: planet_type 191 #ifdef CPP_IOIPSL192 USE IOIPSL, ONLY: getin193 #else194 USE ioipsl_getincom, only: getin195 #endif196 #ifdef CPP_PARA197 USE parallel_lmdz, ONLY: is_master198 #endif199 116 #ifdef REPROBUS 200 USE CHEM_REP, ONLY: Init_chem_rep_trac117 USE CHEM_REP, ONLY: Init_chem_rep_trac 201 118 #endif 202 119 IMPLICIT NONE … … 225 142 !------------------------------------------------------------------------------------------------------------------------------ 226 143 ! Local variables 227 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) , itmp(:)!--- Horizontal/vertical transport scheme number144 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) !--- Horizontal/vertical transport scheme number 228 145 #ifdef INCA 229 146 INTEGER, ALLOCATABLE :: had (:), hadv_inca(:), conv_flg_inca(:), &!--- Variables specific to INCA … … 232 149 INTEGER :: nqINCA 233 150 #endif 234 #ifndef CPP_PARA235 LOGICAL :: is_master=.TRUE.236 #endif237 151 CHARACTER(LEN=2) :: suff(9) !--- Suffixes for schemes of order 3 or 4 (Prather) 238 152 CHARACTER(LEN=3) :: descrq(30) !--- Advection scheme description tags 239 CHARACTER(LEN=maxlen) :: msg1, texp, ttp , ky, nam, val!--- Strings for messages and expanded tracers type153 CHARACTER(LEN=maxlen) :: msg1, texp, ttp !--- Strings for messages and expanded tracers type 240 154 INTEGER :: fType !--- Tracers description file type ; 0: none 241 155 !--- 1/2/3: "traceur.def"/"tracer.def"/"tracer_*.def" 242 156 INTEGER :: nqtrue !--- Tracers nb from tracer.def (no higher order moments) 243 157 INTEGER :: iad !--- Advection scheme number 244 INTEGER :: iq, jq, it, nt, im, nm, ig !--- Indexes and temporary variables 245 LOGICAL :: lerr, lInit 246 TYPE(keys_type), ALLOCATABLE, TARGET :: tra(:) !--- Tracers descriptor as in readTracFiles_mod 247 TYPE(tisot), ALLOCATABLE :: iso(:) !--- Isotopes descriptor as in readTracFiles_mod 158 INTEGER :: iq, jq, nt, im, nm !--- Indexes and temporary variables 159 LOGICAL :: lerr, ll 248 160 TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:) 249 TYPE(trac_type), POINTER :: t (:), t1250 TYPE(keys_type), POINTER :: k(:)251 CHARACTER(LEN=maxlen), ALLOCATABLE :: types_trac(:) !--- Keywords for tracers type(s), parsed version 161 TYPE(trac_type), POINTER :: t1, t(:) 162 CHARACTER(LEN=maxlen), ALLOCATABLE :: types_trac(:) !--- Keyword for tracers type(s), parsed version 163 252 164 CHARACTER(LEN=*), PARAMETER :: modname="init_infotrac" 253 165 !------------------------------------------------------------------------------------------------------------------------------ … … 259 171 descrq(10:20) = ['VL1','VLP','FH1','FH2','VLH',' ','PPM','PPS','PPP',' ','SLP'] 260 172 descrq(30) = 'PRA' 261 262 CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname, is_master) 263 IF(strCount(type_trac, '|', nt)) CALL abort_gcm(modname, 'Could''nt parse the "type_trac" string with delimiter "|"', 1) 264 IF(nt >= 3) CALL abort_gcm(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1) 265 IF(strParse(type_trac, '|', types_trac, n=nt)) CALL abort_gcm(modname, "couldn't parse "//'"type_trac"', 1) 266 IF(nt == 2) type_trac = types_trac(2) ! TO BE DELETED SOON 267 268 lInit = .NOT.ALLOCATED(trac) 269 270 !############################################################################################################################## 271 IF(lInit .AND. is_master) THEN !=== SKIPED IF ALREADY DONE 272 !############################################################################################################################## 173 174 CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname) 175 176 lerr=strParse(type_trac, '|', types_trac, n=nt) 177 IF (nt .GT. 1) THEN 178 IF (nt .GT. 2) CALL abort_gcm(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1) 179 if (nt .EQ. 2) type_trac=types_trac(2) 180 ENDIF 181 182 183 273 184 !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION 274 185 msg1 = 'For type_trac = "'//TRIM(type_trac)//'":' … … 298 209 #endif 299 210 END SELECT 300 !############################################################################################################################## 301 END IF 302 !############################################################################################################################## 303 304 !============================================================================================================================== 305 ! 0) DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE AND READ IT ; TRANSFER THE NEEDED QUANTITIES TO LOCAL "tracers". 306 !============================================================================================================================== 307 texp = type_trac !=== EXPANDED (WITH "|" SEPARATOR) "type_trac" 211 212 nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] ) 213 214 !============================================================================================================================== 215 ! 1) Get the numbers of: true (first order only) tracers "nqtrue", water tracers "nqo" (vapor/liquid/solid) 216 !============================================================================================================================== 217 texp = type_trac !=== EXPANDED VERSION OF "type_trac", WITH "|" SEPARATOR 308 218 IF(texp == 'inco') texp = 'co2i|inca' 309 219 IF(texp /= 'lmdz') texp = 'lmdz|'//TRIM(texp) 310 IF(testTracersFiles(modname, texp, fType, lInit.AND.is_master)) CALL abort_gcm(modname, 'problem with tracers file(s)',1) 220 221 !=== DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE 222 IF(testTracersFiles(modname, texp, fType, .TRUE.)) CALL abort_gcm(modname, 'problem with tracers file(s)',1) 311 223 ttp = type_trac; IF(fType /= 1) ttp = texp 312 !--------------------------------------------------------------------------------------------------------------------------- 313 IF(fType == 0) CALL abort_gcm(modname, 'Missing "traceur.def", "tracer.def" or "tracer_<keyword>.def tracers file.',1) 314 !--------------------------------------------------------------------------------------------------------------------------- 315 IF(fType == 1 .AND. ANY(['inca', 'inco'] == type_trac) .AND. lInit) & !=== FOUND OLD STYLE INCA "traceur.def" 316 CALL abort_gcm(modname, 'retro-compatibility with old-style INCA traceur.def files has been disabled.', 1) 317 !--------------------------------------------------------------------------------------------------------------------------- 318 319 !############################################################################################################################## 320 IF(lInit) THEN 321 IF(readTracersFiles(ttp, tra, type_trac == 'repr')) CALL abort_gcm(modname, 'problem with tracers file(s)',1) 322 ELSE 323 tra = trac 224 225 IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_gcm(modname, 'problem with tracers file(s)',1) 226 !--------------------------------------------------------------------------------------------------------------------------- 227 IF(fType == 0) CALL abort_gcm(modname, 'Missing tracers file: "traceur.def", "tracer.def" or "tracer_<keyword>.def file.',1) 228 !--------------------------------------------------------------------------------------------------------------------------- 229 IF(fType == 1 .AND. ANY(['inca','inco']==type_trac)) THEN !=== FOUND OLD STYLE INCA "traceur.def" 230 !--------------------------------------------------------------------------------------------------------------------------- 231 #ifdef INCA 232 nqo = SIZE(tracers) - nqCO2 233 CALL Init_chem_inca_trac(nqINCA) !--- Get nqINCA from INCA 234 nbtr = nqINCA + nqCO2 !--- Number of tracers passed to phytrac 235 nqtrue = nbtr + nqo !--- Total number of "true" tracers 236 IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1) 237 ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA)) 238 ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA), pbl_flg_inca(nqINCA)) 239 CALL init_transport(solsym_inca, conv_flg_inca, pbl_flg_inca, hadv_inca, vadv_inca) 240 ALLOCATE(ttr(nqtrue)) 241 ttr(1:nqo+nqCO2) = tracers 242 ttr(1 : nqo )%component = 'lmdz' 243 ttr(1+nqo:nqCO2+nqo )%component = 'co2i' 244 ttr(1+nqo+nqCO2:nqtrue)%component = 'inca' 245 ttr(1+nqo :nqtrue)%name = [('CO2 ', iq=1, nqCO2), solsym_inca] 246 ttr(1+nqo+nqCO2:nqtrue)%parent = tran0 247 ttr(1+nqo+nqCO2:nqtrue)%phase = 'g' 248 lerr = getKey('hadv', had, ky=tracers(:)%keys) 249 lerr = getKey('vadv', vad, ky=tracers(:)%keys) 250 hadv(1:nqo+nqCO2) = had(:); hadv(1+nqo+nqCO2:nqtrue) = hadv_inca 251 vadv(1:nqo+nqCO2) = vad(:); vadv(1+nqo+nqCO2:nqtrue) = vadv_inca 252 CALL MOVE_ALLOC(FROM=ttr, TO=tracers) 253 DO iq = 1, nqtrue 254 t1 => tracers(iq) 255 CALL addKey('name', t1%name, t1%keys) 256 CALL addKey('component', t1%component, t1%keys) 257 CALL addKey('parent', t1%parent, t1%keys) 258 CALL addKey('phase', t1%phase, t1%keys) 259 END DO 260 IF(setGeneration(tracers)) CALL abort_gcm(modname,'See above',1) !- SET FIELDS %iGeneration, %gen0Name 261 DEALLOCATE(had, hadv_inca, vad, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca) 262 #endif 263 !--------------------------------------------------------------------------------------------------------------------------- 264 ELSE !=== OTHER CASES (OLD OR NEW FORMAT, NO INCA MODULE) 265 !--------------------------------------------------------------------------------------------------------------------------- 266 nqo = COUNT(delPhase(tracers(:)%name) == 'H2O' & 267 .AND. tracers(:)%component == 'lmdz') !--- Number of water phases 268 nqtrue = SIZE(tracers) !--- Total number of "true" tracers 269 nbtr = nqtrue-COUNT(delPhase(tracers(:)%gen0Name) == 'H2O' & 270 .AND. tracers(:)%component == 'lmdz') !--- Number of tracers passed to phytrac 271 #ifdef INCA 272 nqINCA = COUNT(tracers(:)%component == 'inca') 273 #endif 274 lerr = getKey('hadv', hadv, ky=tracers(:)%keys) 275 lerr = getKey('vadv', vadv, ky=tracers(:)%keys) 276 !--------------------------------------------------------------------------------------------------------------------------- 324 277 END IF 325 CALL msg('No tracers description file(s) reading needed: already done', modname, .NOT.lInit.AND.is_master) 326 !############################################################################################################################## 327 328 !--- POPULATE SOME EXPLICIT (ACCESSIBLE THROUGH "%") KEYS OF THE LOCAL TRACERS DESCRIPTION DERIVED TYPE 329 ! To be defined: iqParent, iq/nqDescen, nqChildren (in indexUpdate), longName, iso_i*, iadv (later) 330 ALLOCATE(tracers(SIZE(tra))) 331 DO iq = 1, SIZE(tra); t1 => tracers(iq) 332 t1%keys = tra(iq) 333 msg1 = '" for tracer nr. '//TRIM(int2str(iq)) 334 ky='name '; IF(getKey(ky, t1%name, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 335 msg1 = '" for "'//TRIM(t1%name)//'"' 336 ky='gen0Name '; IF(getKey(ky, t1%gen0Name, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 337 ky='parent '; IF(getKey(ky, t1%parent, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 338 ky='type '; IF(getKey(ky, t1%type, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 339 ky='phase '; IF(getKey(ky, t1%phase, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 340 ky='component '; IF(getKey(ky, t1%component, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 341 ky='iGeneration'; IF(getKey(ky, t1%iGeneration, iq, tra)) CALL abort_gcm(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 342 END DO 343 344 !============================================================================================================================== 345 ! 1) Get various numbers: "nqtrue" (first order only tracers), "nqo" (water phases), 'nbtr' (tracers passed to physics), etc. 346 !============================================================================================================================== 347 nqtrue = SIZE(tracers) !--- "true" tracers 348 nqo = COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%name) == 'H2O') !--- Water phases 349 nbtr = nqtrue-COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%gen0Name) == 'H2O') !--- Passed to phytrac 350 nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] ) 351 #ifdef INCA 352 nqINCA = COUNT(tracers(:)%component == 'inca') 353 #endif 278 !--------------------------------------------------------------------------------------------------------------------------- 279 354 280 #ifdef REPROBUS 355 CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name) !--- Transfert the number of tracers to Reprobus 356 #endif 357 281 !--- Transfert the number of tracers to Reprobus 282 CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name) 283 284 #endif 358 285 !============================================================================================================================== 359 286 ! 2) Calculate nqtot, number of tracers needed (greater if advection schemes 20 or 30 have been chosen). 360 287 !============================================================================================================================== 361 IF(getKey('hadv', hadv, ky=tra)) CALL abort_gcm(modname, 'missing key "hadv"', 1)362 IF(getKey('vadv', vadv, ky=tra)) CALL abort_gcm(modname, 'missing key "vadv"', 1)363 288 DO iq = 1, nqtrue 364 289 IF( hadv(iq)<20 .OR. (ANY(hadv(iq)==[20,30]) .AND. hadv(iq)==vadv(iq)) ) CYCLE … … 378 303 379 304 !============================================================================================================================== 380 ! 3) Determine the advection scheme choice for water and tracers "iadv" and the fields long name .305 ! 3) Determine the advection scheme choice for water and tracers "iadv" and the fields long name, isAdvected. 381 306 ! iadv = 1 "LMDZ-specific humidity transport" (for H2O vapour) LMV 382 307 ! iadv = 2 backward (for H2O liquid) BAK … … 396 321 !============================================================================================================================== 397 322 ALLOCATE(ttr(nqtot)) 398 jq = nqtrue+1 323 jq = nqtrue+1; tracers(:)%iadv = -1 399 324 DO iq = 1, nqtrue 400 325 t1 => tracers(iq) … … 407 332 IF(iad == -1) CALL abort_gcm(modname, msg1, 1) 408 333 409 !--- SET FIELDS longName, iadv 334 !--- SET FIELDS %longName, %iadv, %isAdvected, %isInPhysics 335 t1%longName = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad) 410 336 t1%iadv = iad 411 t1%longName = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad) 337 t1%isAdvected = iad >= 0 338 t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' & 339 .OR. t1%component /= 'lmdz' !=== OTHER EXCEPTIONS TO BE ADDED: CO2i, SURSATURATED WATER CLOUD... 412 340 ttr(iq) = t1 413 341 … … 419 347 ttr(jq+1:jq+nm) = t1 420 348 ttr(jq+1:jq+nm)%name = [ (TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ] 421 ttr(jq+1:jq+nm)%gen0Name = [ (TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ]422 349 ttr(jq+1:jq+nm)%parent = [ (TRIM(t1%parent) //'-'//TRIM(suff(im)), im=1, nm) ] 423 350 ttr(jq+1:jq+nm)%longName = [ (TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ] 424 351 ttr(jq+1:jq+nm)%iadv = [ (-iad, im=1, nm) ] 352 ttr(jq+1:jq+nm)%isAdvected = [ (.FALSE., im=1, nm) ] 425 353 jq = jq + nm 426 354 END DO … … 428 356 CALL MOVE_ALLOC(FROM=ttr, TO=tracers) 429 357 430 !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren 431 IF(indexUpdate(tracers%keys)) CALL abort_gcm(modname, 'problem with tracers indices update', 1) 432 k => tracers(:)%keys 433 DO iq = 1, SIZE(tracers); t1 => tracers(iq); msg1 = '" for "'//TRIM(t1%name)//'"' 434 ky='iqParent '; IF(getKey(ky, t1%iqParent, iq, k)) CALL abort_gcm(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 435 ky='iqDescen '; IF(getKey(ky, t1%iqDescen, iq, k)) CALL abort_gcm(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 436 ky='nqDescen '; IF(getKey(ky, t1%nqDescen, iq, k)) CALL abort_gcm(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 437 ky='nqChildren'; IF(getKey(ky, t1%nqChildren, iq, k)) CALL abort_gcm(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 358 !--- SET FIELDS %iqParent, %nqChildren, %iGeneration, %iqDescen, %nqDescen 359 IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem with tracers indices update', 1) 360 361 !=== TEST ADVECTION SCHEME 362 DO iq=1,nqtot ; t1 => tracers(iq); iad = t1%iadv 363 364 !--- ONLY TESTED VALUES FOR TRACERS FOR NOW: iadv = 14, 10 (and 0 for non-transported tracers) 365 IF(ALL([10,14,0] /= iad)) & 366 CALL abort_gcm(modname, 'Not tested for iadv='//TRIM(int2str(iad))//' ; 10 or 14 only are allowed !', 1) 367 368 !--- ONLY TESTED VALUES FOR PARENTS HAVING CHILDS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1) 369 IF(ALL([10,14] /= iad) .AND. t1%iGeneration == 1 .AND. ANY(tracers(:)%iGeneration > 1)) & 370 CALL abort_gcm(modname, 'iadv='//TRIM(int2str(iad))//' not implemented for parents ; 10 or 14 only are allowed !', 1) 371 372 !--- ONLY TESTED VALUES FOR CHILDS FOR NOW: iadv = 10 (CHILDS: TRACERS OF GENERATION GREATER THAN 1) 373 IF(fmsg('WARNING ! iadv='//TRIM(int2str(iad))//' not implemented for childs. Setting iadv=10 for "'//TRIM(t1%name)//'"',& 374 modname, iad /= 10 .AND. t1%iGeneration > 1)) t1%iadv = 10 375 376 !--- ONLY VALID SCHEME NUMBER FOR WATER VAPOUR: iadv = 14 377 ll = t1%name /= addPhase('H2O','g') 378 IF(fmsg('WARNING ! iadv=14 is valid for water vapour only. Setting iadv=10 for "'//TRIM(t1%name)//'".', & 379 modname, iad == 14 .AND. ll)) t1%iadv = 10 438 380 END DO 439 381 440 !=== TEST ADVECTION SCHEME 441 DO iq = 1, nqtot ; t1 => tracers(iq) 442 iad = t1%iadv 443 ig = t1%iGeneration 444 nam = t1%name 445 val = 'iadv='//TRIM(int2str(iad)) 446 447 !--- ONLY TESTED VALUES FOR TRACERS FOR NOW: iadv = 14, 10 (and 0 for non-transported tracers) 448 IF(ALL([10,14,0] /= iad)) CALL abort_gcm(modname, TRIM(val)//' has not been tested yet ; 10 or 14 only are allowed !', 1) 449 450 !--- ONLY TESTED VALUES SO FAR FOR PARENTS HAVING CHILDREN: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 0) 451 IF(ALL([10,14] /= iad) .AND. ig == 0 .AND. ANY(tracers(:)%parent==nam)) & 452 CALL abort_gcm(modname, TRIM(val)//' is not implemented for parents ; 10 or 14 only are allowed !', 1) 453 454 !--- ONLY TESTED VALUES SO FAR FOR DESCENDANTS (TRACERS OF GENERATION > 0): iadv = 10 ; WATER VAPOUR: iadv = 14 455 lerr = iad /= 10 .AND. ig > 0; IF(lerr) tracers(iq)%iadv = 10 456 CALL msg('WARNING! '//TRIM(val)// ' not implemented for children. Setting iadv=10 for "'//TRIM(nam)//'"', modname, lerr) 457 lerr = iad == 14 .AND. nam /= addPhase('H2O','g'); IF(lerr) tracers(iq)%iadv = 10 458 CALL msg('WARNING! '//TRIM(val)//' is valid for water vapour only. Setting iadv=10 for "'//TRIM(nam)//'"', modname, lerr) 459 END DO 460 461 !=== DETERMINE ISOTOPES RELATED PARAMETERS ; DEFINE THE EXPLICIT KEYS iso_i* 462 IF(processIsotopes(tracers%keys, iso)) CALL abort_gcm(modname, 'problem while processing isotopes parameters', 1) 463 464 !--- POPULATE SOME EXPLICIT (ACCESSIBLE THROUGH "%") KEYS OF THE LOCAL ISOTOPES DESCRIPTION DERIVED TYPE 465 nbIso = SIZE(iso) 466 ALLOCATE(isotopes(nbIso)) 467 IF(nbIso /= 0) THEN 468 k => tracers(:)%keys 469 IF(getKey('iso_iGroup', itmp, ky=k)) CALL abort_gcm(modname, 'missing key "iso_iGroup"', 1); tracers%iso_iGroup=itmp 470 IF(getKey('iso_iName', itmp, ky=k)) CALL abort_gcm(modname, 'missing key "iso_iName"', 1); tracers%iso_iName =itmp 471 IF(getKey('iso_iZone', itmp, ky=k)) CALL abort_gcm(modname, 'missing key "iso_iZone"', 1); tracers%iso_iZone =itmp 472 IF(getKey('iso_iPhas', itmp, ky=k)) CALL abort_gcm(modname, 'missing key "iso_iPhas"', 1); tracers%iso_iPhase=itmp 473 isotopes(:)%name = iso(:)%name !--- Isotopes family name (ex: H2O) 474 isotopes(:)%phase = iso(:)%phase !--- Phases list: [g][l][s] (length: nphas) 475 isotopes(:)%niso = iso(:)%niso !--- Number of isotopes, excluding tagging tracers 476 isotopes(:)%ntiso = iso(:)%ntiso !--- Number of isotopes, including tagging tracers 477 isotopes(:)%nzone = iso(:)%nzone !--- Number of geographic tagging zones 478 isotopes(:)%nphas = iso(:)%nphas !--- Number of phases 479 isotopes(:)%check = .FALSE. !--- Flag for checking routines triggering 480 CALL getin('ok_iso_verif', isotopes(:)%check) 481 DO it = 1, nbIso 482 isotopes(it)%keys = iso(it)%keys !--- Isotopes keys/values pairs list (length: niso) 483 isotopes(it)%trac = iso(it)%trac !--- Isotopes + tagging tracers list (length: ntiso) 484 isotopes(it)%zone = iso(it)%zone !--- Geographic tagging zones names list (length: nzone) 485 isotopes(it)%iqIsoPha = iso(it)%iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 486 isotopes(it)%itZonIso = iso(it)%itZonIso(:,:) !--- Idx in "tracers(1:ntiso)" = f( zone,name(1:niso)) 487 END DO 488 IF(isoSelect(1, .TRUE.)) CALL abort_gcm(modname, "Can't select the first isotopes family", 1) 489 IF(.NOT.isoSelect('H2O', .TRUE.)) iH2O = ixIso 490 END IF 491 isoFamilies = isotopes(:)%name 382 !=== READ PHYSICAL PARAMETERS FOR ISOTOPES ; DONE HERE BECAUSE dynetat0 AND iniacademic NEED "tnat" AND "alpha_ideal" 383 niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE. 384 IF(processIsotopes()) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1) 492 385 493 386 !--- Convection / boundary layer activation for all tracers 494 IF(.NOT.ALLOCATED(conv_flg))ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1495 IF(.NOT.ALLOCATED( pbl_flg))ALLOCATE( pbl_flg(nbtr)); pbl_flg(1:nbtr) = 1387 ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1 388 ALLOCATE( pbl_flg(nbtr)); pbl_flg(1:nbtr) = 1 496 389 497 390 !--- Note: nqtottr can differ from nbtr when nmom/=0 … … 501 394 502 395 !=== DISPLAY THE RESULTS 503 IF(.NOT.is_master) RETURN504 396 CALL msg('nqo = '//TRIM(int2str(nqo)), modname) 505 397 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) … … 513 405 #endif 514 406 t => tracers 515 CALL msg('Information stored in '//TRIM(modname)//': ', modname) 516 IF(dispTable('isssssssiiiiiiiii', ['iq ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp', & 517 'iAdv', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'], & 518 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component), & 407 CALL msg('Information stored in infotrac :', modname) 408 409 IF(dispTable('isssssssssiiiiiiiii', ['iq ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp', & 410 'isPh', 'isAd', 'iadv', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'], & 411 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isInPhysics), & 412 bool2str(t%isAdvected)), & 519 413 cat([(iq, iq=1, nqtot)], t%iadv, t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup, & 520 414 t%iso_iName, t%iso_iZone, t%iso_iPhase), nColMax=maxTableWidth, nHead=2, sub=modname)) & 521 415 CALL abort_gcm(modname, "problem with the tracers table content", 1) 522 CALL msg('No isotopes identified.', modname, nbIso == 0) 523 IF(nbIso == 0) RETURN 524 DO it = 1, nbIso 525 IF(isoSelect(it, .TRUE.)) CALL abort_gcm(modname, 'Problem when selecting isotopes class', 1) 526 CALL msg('For isotopes family "'//TRIM(isoFamilies(it))//'":', modname) 527 CALL msg(' isoName = '//strStack(isotope%trac), modname) 528 CALL msg(' isoZone = '//strStack(isotope%zone), modname) 529 CALL msg(' isoPhas = '// TRIM(isotope%phase), modname) 530 END DO 531 IF(isoSelect('H2O', .TRUE.)) THEN 532 IF(isoSelect(1, .TRUE.)) CALL abort_gcm(modname, 'Problem when selecting isotopes class', 1) 416 IF(niso > 0) THEN 417 CALL msg('Where, for isotopes family "'//TRIM(isotope%parent)//'":', modname) 418 CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) 419 CALL msg(' isoName = '//strStack(isoName), modname) 420 CALL msg(' isoZone = '//strStack(isoZone), modname) 421 CALL msg(' isoPhas = '//TRIM(isoPhas), modname) 533 422 ELSE 534 iH2O = ixIso423 CALL msg('No isotopes identified.', modname) 535 424 END IF 536 IF(ALLOCATED(isotope%keys(ixIso)%key)) & 537 CALL msg(' isoKeys('//TRIM(int2str(ixIso))//') = '//TRIM(strStack(isotope%keys(ixIso)%key)), modname) 425 CALL msg('end', modname) 538 426 539 427 END SUBROUTINE init_infotrac 540 428 541 !==============================================================================================================================542 LOGICAL FUNCTION isoSelectByName(iClass, lVerbose) RESULT(lerr)543 IMPLICIT NONE544 CHARACTER(LEN=*), INTENT(IN) :: iClass545 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose546 INTEGER :: iIso547 LOGICAL :: lV548 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose549 iIso = strIdx(isotopes(:)%name, iClass)550 lerr = iIso == 0551 IF(lerr) THEN552 niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.553 CALL msg('no isotope family named "'//TRIM(iClass)//'"', ll=lV)554 RETURN555 END IF556 lerr = isoSelectByIndex(iIso, lV)557 END FUNCTION isoSelectByName558 !==============================================================================================================================559 LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)560 IMPLICIT NONE561 INTEGER, INTENT(IN) :: iIso562 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose563 LOGICAL :: lV564 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose565 lerr = .FALSE.566 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK567 lerr = iIso<=0 .OR. iIso>SIZE(isotopes)568 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '&569 //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV)570 IF(lerr) RETURN571 ixIso = iIso !--- Update currently selected family index572 isotope => isotopes(ixIso) !--- Select corresponding component573 isoKeys => isotope%keys; niso = isotope%niso574 isoName => isotope%trac; ntiso = isotope%ntiso575 isoZone => isotope%zone; nzone = isotope%nzone576 isoPhas => isotope%phase; nphas = isotope%nphas577 itZonIso => isotope%itZonIso; isoCheck = isotope%check578 iqIsoPha => isotope%iqIsoPha579 END FUNCTION isoSelectByIndex580 !==============================================================================================================================581 582 429 END MODULE infotrac -
LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F
r5183 r5190 64 64 function iso_verif_aberrant_nostop 65 65 : (x,iso,q,err_msg) 66 #ifdef CPP_IOIPSL 67 USE IOIPSL, ONLY: getin 68 #else 69 USE ioipsl_getincom, ONLY: getin 70 #endif 71 USE iso_params_mod, ONLY: tnat_HDO 66 USE infotrac, ONLY: isoName, getKey 72 67 implicit none 73 68 … … 79 74 ! locals 80 75 real qmin,deltaD 81 real deltaDmax,deltaDmin 76 real deltaDmax,deltaDmin,tnat 82 77 parameter (qmin=1e-11) 83 78 parameter (deltaDmax=200.0,deltaDmin=-999.9) 84 LOGICAL :: ltnat185 LOGICAL, SAVE :: lFirst=.TRUE.86 REAL, SAVE :: tnat87 79 88 80 ! output 89 81 integer iso_verif_aberrant_nostop 90 82 91 IF(lFirst) THEN92 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)93 tnat = tnat_HDO; IF(ltnat1) tnat = 1.094 lFirst = .FALSE.95 END IF96 83 iso_verif_aberrant_nostop=0 97 84 98 85 ! verifier que HDO est raisonable 99 86 if (q.gt.qmin) then 87 IF(getKey('tnat', tnat, isoName(iso))) THEN 88 err_msg = 'Missing isotopic parameter "tnat"' 89 iso_verif_aberrant_nostop=1 90 RETURN 91 END IF 100 92 deltaD=(x/q/tnat-1)*1000 101 93 if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then -
LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.F90
r5183 r5190 3 3 USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str 4 4 USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & 5 ntiso, iH2O, nzone, tracers, isoName, itZonIso 6 USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO 7 #ifdef CPP_IOIPSL 8 USE ioipsl, ONLY: getin 9 #else 10 USE ioipsl_getincom, ONLY: getin 11 #endif 5 ntiso, iH2O, nzone, tracers, isoName, itZonIso, getKey 12 6 IMPLICIT NONE 13 7 include "dimensions.h" … … 27 21 deltaDmin =-999.0, & 28 22 ridicule = 1e-12 29 INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO 30 !$OMP THREADPRIVATE(iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO) 31 LOGICAL :: ltnat1 23 INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, & !--- OpenMP shared variables 24 iso_O17, iso_HTO 32 25 LOGICAL, SAVE :: first=.TRUE. 26 LOGICAL, PARAMETER :: tnat1=.TRUE. 33 27 !$OMP THREADPRIVATE(first) 34 28 … … 38 32 IF(niso == 0) RETURN !--- No isotopes => finished 39 33 IF(first) THEN 40 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1) 41 iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O 42 iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O 43 iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O 44 iso_HDO = strIdx(isoName,'HDO'); IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO 45 iso_HTO = strIdx(isoName,'HTO'); IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO 46 IF(ltnat1) tnat(:) = 1.0 34 !$OMP MASTER 35 iso_eau = strIdx(isoName,'H216O') 36 iso_HDO = strIdx(isoName,'HDO') 37 iso_O18 = strIdx(isoName,'H218O') 38 iso_O17 = strIdx(isoName,'H217O') 39 iso_HTO = strIdx(isoName,'HTO') 40 if (tnat1) then 41 tnat(:)=1.0 42 else 43 IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1) 44 endif 45 !$OMP END MASTER 46 !$OMP BARRIER 47 47 first = .FALSE. 48 48 END IF -
LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90
r5183 r5190 7 7 !------------------------------------------------------------------------------- 8 8 USE parallel_lmdz 9 USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, & 10 new2oldH2O, newHNO3, oldHNO3 9 USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName 11 10 USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx 12 11 USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, & 13 12 NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE, NF90_NoErr 13 USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey 14 14 USE control_mod, ONLY: planet_type 15 15 USE assert_eq_m, ONLY: assert_eq … … 20 20 USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time 21 21 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 22 #ifdef CPP_IOIPSL23 USE IOIPSL, ONLY: getin24 #else25 USE ioipsl_getincom, ONLY: getin26 #endif27 USE iso_params_mod ! tnat_* and alpha_ideal_*28 22 29 23 IMPLICIT NONE … … 53 47 REAL, ALLOCATABLE :: ucov_glo(:,:), q_glo(:,:), phis_glo(:) 54 48 REAL, ALLOCATABLE :: teta_glo(:,:) 55 LOGICAL :: lSkip, ll, ltnat1 49 LOGICAL :: lSkip, ll 50 LOGICAL,PARAMETER :: tnat1=.TRUE. 56 51 !------------------------------------------------------------------------------- 57 52 modname="dynetat0_loc" … … 163 158 ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr !--- DETECT OLD REPRO start.nc FILE 164 159 #endif 165 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)166 160 DO iq=1,nqtot 167 161 var = tracers(iq)%name … … 179 173 !-------------------------------------------------------------------------------------------------------------------------- 180 174 ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN !=== TRY WITH ALTERNATE NAME 181 CALL msg(' Missing tracer <'//TRIM(var)//'>=> initialized to <'//TRIM(oldVar)//'>', modname)175 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname) 182 176 CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:) 183 177 !-------------------------------------------------------------------------------------------------------------------------- … … 187 181 iqParent = tracers(iq)%iqParent 188 182 IF(tracers(iq)%iso_iZone == 0) THEN 189 IF(ltnat1) THEN 190 tnat = 1.0 191 alpha_ideal = 1.0 192 CALL msg(' !!! Beware: alpha_ideal put to 1 !!!', modname) 193 ELSE 194 SELECT CASE(isoName(iName)) 195 CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O 196 CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O 197 CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O 198 CASE('HDO'); tnat = tnat_HDO; alpha_ideal = alpha_ideal_HDO 199 CASE('HTO'); tnat = tnat_HTO; alpha_ideal = alpha_ideal_HTO 200 CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1) 201 END SELECT 202 END IF 203 CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname) 183 if (tnat1) then 184 tnat=1.0 185 alpha_ideal=1.0 186 write(*,*) 'attention dans dynetat0: les alpha_ideal sont a 1' 187 else 188 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) & 189 CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1) 190 endif 191 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname) 204 192 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.) 205 193 ! Camille 9 mars 2023: point de vigilence: initialisation incohérente 206 194 ! avec celle de xt_ancien dans la physiq. 207 195 ELSE 208 CALL msg(' Missing tracer <'//TRIM(var)//'>=> initialized to its parent isotope concentration.', modname)196 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to its parent isotope concentration.', modname) 209 197 ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à 210 198 ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme … … 220 208 !-------------------------------------------------------------------------------------------------------------------------- 221 209 ELSE !=== MISSING: SET TO 0 222 CALL msg(' missing tracer <'//TRIM(var)//'>=> initialized to zero', modname)210 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to zero', modname) 223 211 q(ijb_u:ije_u,:,iq)=0. 224 212 !-------------------------------------------------------------------------------------------------------------------------- -
LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.F90
r5183 r5190 5 5 6 6 USE filtreg_mod, ONLY: inifilr 7 USE infotrac, ONLY: nqtot, niso, iqIsoPha, tracers, addPhase, isoName7 USE infotrac, ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName 8 8 USE control_mod, ONLY: day_step,planet_type 9 9 use exner_hyb_m, only: exner_hyb … … 22 22 USE temps_mod, ONLY: annee_ref, day_ini, day_ref 23 23 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 24 USE readTracFiles_mod, ONLY: addPhase 24 25 use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID 25 26 use netcdf, only : NF90_CLOSE, NF90_GET_VAR 26 USE iso_params_mod ! tnat_* and alpha_ideal_*27 27 28 28 … … 85 85 86 86 REAL zdtvr, tnat, alpha_ideal 87 LOGICAL :: ltnat187 LOGICAL,PARAMETER :: tnat1=.true. 88 88 89 89 character(len=*),parameter :: modname="iniacademic" … … 311 311 ! bulk initialization of tracers 312 312 if (planet_type=="earth") then 313 ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)314 313 ! Earth: first two tracers will be water 315 314 do iq=1,nqtot … … 325 324 iqParent = tracers(iq)%iqParent 326 325 IF(tracers(iq)%iso_iZone == 0) THEN 327 IF(ltnat1) THEN 328 tnat = 1.0 329 alpha_ideal = 1.0 330 WRITE(lunout, *) 'In '//TRIM(modname)//': !!! Beware: alpha_ideal put to 1 !!!' 331 ELSE 332 SELECT CASE(isoName(iName)) 333 CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O 334 CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O 335 CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O 336 CASE('HDO'); tnat = tnat_HDO; alpha_ideal = alpha_ideal_HDO 337 CASE('HTO'); tnat = tnat_HTO; alpha_ideal = alpha_ideal_HTO 338 CASE DEFAULT 339 CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1) 340 END SELECT 341 END IF 326 if (tnat1) then 327 tnat=1.0 328 alpha_ideal=1.0 329 write(*,*) 'Attention dans iniacademic: alpha_ideal=1' 330 else 331 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) & 332 CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1) 333 endif 342 334 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.) 343 335 ELSE !IF(tracers(iq)%iso_iZone == 0) THEN -
LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.F
r5183 r5190 4 4 SUBROUTINE qminimum_loc( q,nqtot,deltap ) 5 5 USE parallel_lmdz 6 USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase,6 USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, 7 7 & isoCheck, min_qParent 8 8 USE strings_mod, ONLY: strIdx 9 USE readTracFiles_mod, ONLY: addPhase 9 10 IMPLICIT none 10 11 c -
LMDZ6/trunk/libf/dynphy_lonlat/calfis.F
r5183 r5190 29 29 c Auteur : P. Le Van, F. Hourdin 30 30 c ......... 31 USE infotrac _phy, ONLY: nqtot, tracers31 USE infotrac, ONLY: nqtot, tracers 32 32 USE control_mod, ONLY: planet_type, nsplit_phys 33 33 #ifdef CPP_PHYS -
LMDZ6/trunk/libf/dynphy_lonlat/calfis_loc.F
r5183 r5190 47 47 USE Times 48 48 #endif 49 USE infotrac _phy, ONLY: nqtot, tracers49 USE infotrac, ONLY: nqtot, tracers 50 50 USE control_mod, ONLY: planet_type, nsplit_phys 51 51 #ifdef CPP_PHYS -
LMDZ6/trunk/libf/misc/readTracFiles_mod.f90
r5184 r5190 10 10 11 11 PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH 12 PUBLIC :: keys_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS12 PUBLIC :: trac_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS 13 13 PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES 14 14 PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) 15 15 PUBLIC :: addTracer, delTracer !--- ADD/REMOVE A TRACER FROM 16 PUBLIC :: addKey, delKey, getKey 16 PUBLIC :: addKey, delKey, getKey, keys_type !--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes 17 17 PUBLIC :: addPhase, delPhase, getPhase, getiPhase, & !--- FUNCTIONS RELATED TO THE PHASES 18 18 nphases, old_phases, phases_sep, known_phases, phases_names !--- + ASSOCIATED VARIABLES … … 35 35 PUBLIC :: itZonIso !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx) 36 36 PUBLIC :: iqIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) 37 PUBLIC :: iqWIsoPha !--- SAME AS iqIsoPha BUT ISOTOPES LIST STARTS WITH PARENT TRAC37 PUBLIC :: iqWIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) but with normal water first 38 38 PUBLIC :: isoCheck !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES 39 39 … … 41 41 !------------------------------------------------------------------------------------------------------------------------------ 42 42 TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT 43 CHARACTER(LEN=maxlen) :: name !--- Tracer name 43 44 CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list 44 45 CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list 45 46 END TYPE keys_type 46 47 !------------------------------------------------------------------------------------------------------------------------------ 47 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "name" 48 CHARACTER(LEN=maxlen) :: name !--- Isotopes family name (example: H2O) 48 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name" 49 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer 50 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector 51 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name 52 CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name 53 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix) 54 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag') 55 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid) 56 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca) 57 INTEGER :: iGeneration = -1 !--- Generation number (>=0) 58 INTEGER :: iqParent = 0 !--- Parent index 59 INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order) 60 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations) 61 INTEGER :: nqChildren = 0 !--- Number of children (first generation) 62 INTEGER :: iadv = 10 !--- Advection scheme used 63 LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue 64 LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr 65 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:) 66 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:) 67 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:) 68 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase 69 END TYPE trac_type 70 !------------------------------------------------------------------------------------------------------------------------------ 71 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent" 72 CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O) 49 73 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) 50 74 LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering … … 64 88 TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION 65 89 CHARACTER(LEN=maxlen) :: name !--- Section name 66 TYPE( keys_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors90 TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors 67 91 END TYPE dataBase_type 68 92 !------------------------------------------------------------------------------------------------------------------------------ … … 115 139 116 140 !=== TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey 117 TYPE( keys_type), ALLOCATABLE, TARGET, SAVE :: tracers(:)141 TYPE(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:) 118 142 TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) 119 143 … … 169 193 !------------------------------------------------------------------------------------------------------------------------------ 170 194 CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used 171 TYPE( keys_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:) !--- Tracers descriptor for external storage195 TYPE(trac_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:) !--- Tracers descriptor for external storage 172 196 LOGICAL, OPTIONAL, INTENT(IN) :: lRepr !--- Activate the HNO3 exceptions for REPROBUS 173 197 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) 174 CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname , ttype198 CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname 175 199 INTEGER :: nsec, ierr, it, ntrac, ns, ip, ix, fType 176 200 INTEGER, ALLOCATABLE :: iGen(:) … … 208 232 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 209 233 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 210 k => tracers(it) 234 k => tracers(it)%keys 211 235 212 236 !=== NAME OF THE TRACER … … 214 238 ix = strIdx(oldHNO3, s(3)) 215 239 IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) 216 CALL addKey('name', tname, tracers) !--- Set the name of the tracer 217 ! tracers(it)%name = tname !--- Copy tracers names in keys components 240 tracers(it)%name = tname !--- Set the name of the tracer 241 CALL addKey('name', tname, k) !--- Set the name of the tracer 242 tracers(it)%keys%name = tname !--- Copy tracers names in keys components 218 243 219 244 !=== NAME OF THE COMPONENT 220 245 cname = type_trac !--- Name of the model component 221 246 IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz' 222 CALL addKey('component', cname, tracers) !--- Set the name of the model component 247 tracers(it)%component = cname !--- Set component 248 CALL addKey('component', cname, k) !--- Set the name of the model component 223 249 224 250 !=== NAME OF THE PARENT … … 229 255 IF(ix /= 0 .AND. lRep) pname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) 230 256 END IF 231 CALL addKey('parent', pname, tracers) !--- Set the parent name 257 tracers(it)%parent = pname !--- Set the parent name 258 CALL addKey('parent', pname, k) 232 259 233 260 !=== PHASE AND ADVECTION SCHEMES NUMBERS 234 CALL addKey('phase', known_phases(ip:ip), tracers) !--- Set the phase of the tracer (default: "g"azeous) 261 tracers(it)%phase = known_phases(ip:ip) !--- Set the phase of the tracer (default: "g"azeous) 262 CALL addKey('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous) 235 263 CALL addKey('hadv', s(1), k) !--- Set the horizontal advection schemes number 236 264 CALL addKey('vadv', s(2), k) !--- Set the vertical advection schemes number … … 238 266 CLOSE(90) 239 267 lerr = setGeneration(tracers); IF(lerr) RETURN !--- Set iGeneration and gen0Name 240 lerr = getKey('iGeneration', iGen, tracers(:)) !--- Generation number 268 lerr = getKey('iGeneration', iGen, tracers(:)%keys) !--- Generation number 269 WHERE(iGen == 2) tracers(:)%type = 'tag' !--- Set type: 'tracer' or 'tag' 241 270 DO it = 1, ntrac 242 ttype = 'tracer'; IF(iGen(it) == 2) ttype = 'tag' 243 CALL addKey('type', ttype, tracers(it)) !--- Set the type of tracer 271 CALL addKey('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer 244 272 END DO 245 273 lerr = checkTracers(tracers, fname, fname); IF(lerr) RETURN !--- Detect orphans and check phases … … 263 291 END IF 264 292 lerr = indexUpdate(tracers); IF(lerr) RETURN !--- Set iqParent, iqDescen, nqDescen, nqChildren 265 IF(PRESENT(tracs)) tracs = tracers293 IF(PRESENT(tracs)) CALL MOVE_ALLOC(FROM=tracers, TO=tracs) 266 294 END FUNCTION readTracersFiles 267 295 !============================================================================================================================== … … 311 339 ! Purpose: Read the sections "snames(is)" (pipe-separated list) from each "fnames(is)" 312 340 ! file and create the corresponding tracers set descriptors in the database "dBase": 313 ! * dBase(id)%name : section name314 ! * dBase(id)%trac(:) : tracers descriptor (the key "name" of tracers(i) is the name of the ith tracer)315 ! * dBase(id)%trac(it)%key (:): names of keys associated to tracer dBase(id)%trac(it)%name316 ! * dBase(id)%trac(it)% val(:): values of keys associated to tracer dBase(id)%trac(it)%name341 ! * dBase(id)%name : section name 342 ! * dBase(id)%trac(:)%name : tracers names 343 ! * dBase(id)%trac(it)%keys%key(:): names of keys associated to tracer dBase(id)%trac(it)%name 344 ! * dBase(id)%trac(it)%keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name 317 345 !------------------------------------------------------------------------------------------------------------------------------ 318 346 CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names … … 367 395 ndb= SIZE(dBase) !--- Current number of sections in the database 368 396 IF(PRESENT(defName)) THEN !--- Add default values to all the tracers 369 DO idb=n0,ndb !--- and remove the virtual tracer "defName" 370 lerr = addDefault(dBase(idb)%trac, defName); IF(lerr) RETURN 371 END DO 397 DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName" 372 398 END IF 373 399 ll = strParse(snam, '|', keys = sec) !--- Requested sections names … … 382 408 !------------------------------------------------------------------------------------------------------------------------------ 383 409 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), v(:) 384 TYPE(keys_type), ALLOCATABLE :: tt(:) 410 TYPE(trac_type), ALLOCATABLE :: tt(:) 411 TYPE(trac_type) :: tmp 385 412 CHARACTER(LEN=1024) :: str, str2 386 413 CHARACTER(LEN=maxlen) :: secn … … 418 445 tt = dBase(ndb)%trac(:) 419 446 v(1) = s(1); s(1) = 'name' !--- Convert "name" into a regular key 420 dBase(ndb)%trac = [tt(:), keys_type(s(:), v(:))] 421 DEALLOCATE(tt) 447 tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:)) !--- Set %name and %keys 448 dBase(ndb)%trac = [tt(:), tmp] 449 DEALLOCATE(tt, tmp%keys%key, tmp%keys%val) 422 450 END IF 423 451 END DO … … 432 460 433 461 !============================================================================================================================== 434 LOGICAL FUNCTION addDefault(t, defName) RESULT(lerr)462 SUBROUTINE addDefault(t, defName) 435 463 !------------------------------------------------------------------------------------------------------------------------------ 436 464 ! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. 437 465 !------------------------------------------------------------------------------------------------------------------------------ 438 TYPE( keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)466 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 439 467 CHARACTER(LEN=*), INTENT(IN) :: defName 440 468 INTEGER :: jd, it, k 441 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 442 TYPE(keys_type), ALLOCATABLE :: tt(:) 443 lerr = getKey('name', tname, t(:)); IF(lerr) RETURN 444 jd = strIdx(tname(:), defName) 469 TYPE(keys_type), POINTER :: ky 470 TYPE(trac_type), ALLOCATABLE :: tt(:) 471 jd = strIdx(t(:)%name, defName) 445 472 IF(jd == 0) RETURN 446 DO k = 1, SIZE(t(jd)%key) !--- Loop on the keys of the tracer named "defName" 447 ! CALL addKey(t(jd)%key(k), t(jd)%val(k), t(:), .FALSE.) !--- Add key to all the tracers (no overwriting) 448 DO it = 1, SIZE(t); CALL addKey(t(jd)%key(k), t(jd)%val(k), t(it), .FALSE.); END DO 473 ky => t(jd)%keys 474 DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName" 475 ! CALL addKey(ky%key(k), ky%val(k), t(:)%keys, .FALSE.) !--- Add key to all the tracers (no overwriting) 476 DO it = 1, SIZE(t); CALL addKey(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO 449 477 END DO 450 478 tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" 451 END FUNCTIONaddDefault452 !============================================================================================================================== 453 454 !============================================================================================================================== 455 LOGICAL FUNCTION subDefault(t, defName, lSubLocal) RESULT(lerr)479 END SUBROUTINE addDefault 480 !============================================================================================================================== 481 482 !============================================================================================================================== 483 SUBROUTINE subDefault(t, defName, lSubLocal) 456 484 !------------------------------------------------------------------------------------------------------------------------------ 457 485 ! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. 458 486 ! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE. 459 487 !------------------------------------------------------------------------------------------------------------------------------ 460 TYPE( keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)488 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 461 489 CHARACTER(LEN=*), INTENT(IN) :: defName 462 490 LOGICAL, INTENT(IN) :: lSubLocal 463 491 INTEGER :: i0, it, ik 464 TYPE(keys_type), ALLOCATABLE :: tt(:) 465 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 466 lerr = getKey('name', tname, t(:)); IF(lerr) RETURN 467 i0 = strIdx(tname(:), defName) 492 TYPE(keys_type), POINTER :: k0, ky 493 TYPE(trac_type), ALLOCATABLE :: tt(:) 494 i0 = strIdx(t(:)%name, defName) 468 495 IF(i0 == 0) RETURN 496 k0 => t(i0)%keys 469 497 DO it = 1, SIZE(t); IF(it == i0) CYCLE !--- Loop on the tracers 498 ky => t(it)%keys 470 499 471 500 !--- Substitute in the values of <key>=<val> pairs the keys defined in the virtual tracer "defName" 472 DO ik = 1, SIZE( t(i0)%key); CALL strReplace(t(it)%val, t(i0)%key(ik), t(i0)%val(ik), .TRUE.); END DO501 DO ik = 1, SIZE(k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO 473 502 474 503 IF(.NOT.lSubLocal) CYCLE 475 504 !--- Substitute in the values of <key>=<val> pairs the keys defined locally (in the current tracer) 476 DO ik = 1, SIZE( t(it)%key); CALL strReplace(t(it)%val, t(it)%key(ik), t(it)%val(ik), .TRUE.); END DO505 DO ik = 1, SIZE(ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO 477 506 END DO 478 507 tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" 479 508 480 END FUNCTIONsubDefault509 END SUBROUTINE subDefault 481 510 !============================================================================================================================== 482 511 … … 489 518 ! * Default values are provided for these keys because they are necessary. 490 519 !------------------------------------------------------------------------------------------------------------------------------ 491 TYPE( keys_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector520 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 492 521 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Current section name 493 522 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- Tracers description file name 494 TYPE( keys_type), ALLOCATABLE :: ttr(:)523 TYPE(trac_type), ALLOCATABLE :: ttr(:) 495 524 CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:), tname(:), parent(:), dType(:) 496 525 CHARACTER(LEN=maxlen) :: msg1, modname … … 500 529 lerr = .FALSE. 501 530 nt = SIZE(tr) 502 lerr = getKey('name', tname, tr(:) ); IF(lerr) RETURN503 lerr = getKey('parent', parent, tr(:) , def = tran0); IF(lerr) RETURN504 lerr = getKey('type', dType, tr(:) , def = 'tracer'); IF(lerr) RETURN531 lerr = getKey('name', tname, tr(:)%keys); IF(lerr) RETURN 532 lerr = getKey('parent', parent, tr(:)%keys, def = tran0); IF(lerr) RETURN 533 lerr = getKey('type', dType, tr(:)%keys, def = 'tracer'); IF(lerr) RETURN 505 534 nq = 0 506 535 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 508 537 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 509 538 !--- Extract useful keys: parent name, type, component name 510 CALL addKey('component', sname, tr(it)) 539 tr(it)%component = sname 540 CALL addKey('component', sname, tr(it)%keys) 511 541 512 542 !--- Determine the number of tracers and parents ; coherence checking … … 535 565 DO ipr = 1, npr !--- Loop on parents list elts 536 566 DO itr = 1, ntr !--- Loop on tracers list elts 537 ttr(iq)%key = tr(it)%key 538 ttr(iq)%val = tr(it)%val 539 CALL addKey('name', ta(itr), ttr(iq)) 540 CALL addKey('parent', pa(ipr), ttr(iq)) 541 CALL addKey('type', dType(it), ttr(iq)) 542 CALL addKey('component', sname, ttr(iq)) 567 ttr(iq)%keys%name = TRIM(ta(itr)) 568 ttr(iq)%keys%key = tr(it)%keys%key 569 ttr(iq)%keys%val = tr(it)%keys%val 570 ttr(iq)%name = TRIM(ta(itr)) 571 ttr(iq)%parent = TRIM(pa(ipr)) 572 ttr(iq)%type = dType(it) 573 ttr(iq)%component = sname 574 CALL addKey('name', ta(itr), ttr(iq)%keys) 575 CALL addKey('parent', pa(ipr), ttr(iq)%keys) 576 CALL addKey('type', dType(it), ttr(iq)%keys) 577 CALL addKey('component', sname, ttr(iq)%keys) 543 578 iq = iq + 1 544 579 END DO … … 562 597 ! Check also for orphan tracers (tracers without parent). 563 598 !------------------------------------------------------------------------------------------------------------------------------ 564 TYPE( keys_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector599 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 565 600 INTEGER :: iq, jq, ig 566 601 CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:), tname(:) … … 568 603 CHARACTER(LEN=maxlen) :: modname 569 604 modname = 'setGeneration' 570 lerr = getKey('name', tname, ky=tr(:) ); IF(lerr) RETURN571 lerr = getKey('parent', parent, ky=tr(:) ); IF(lerr) RETURN605 lerr = getKey('name', tname, ky=tr(:)%keys); IF(lerr) RETURN 606 lerr = getKey('parent', parent, ky=tr(:)%keys); IF(lerr) RETURN 572 607 DO iq = 1, SIZE(tr) 573 608 jq = iq; ig = 0 … … 578 613 ig = ig + 1 579 614 END DO 580 CALL addKey('iGeneration', ig, tr(iq)) 581 CALL addKey('gen0Name', tname(jq), tr(iq)) 615 tr(iq)%gen0Name = tname(jq) 616 tr(iq)%iGeneration = ig 617 CALL addKey('iGeneration', ig, tr(iq)%keys) 618 CALL addKey('gen0Name', tname(jq), tr(iq)%keys) 582 619 END DO 583 620 END FUNCTION setGeneration … … 592 629 ! * check wether the phases are known or not (elements of "known_phases") 593 630 !------------------------------------------------------------------------------------------------------------------------------ 594 TYPE( keys_type), INTENT(IN) :: tr(:) !--- Tracers descriptionvector631 TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 595 632 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 596 633 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name … … 607 644 mesg = 'Check section "'//TRIM(sname)//'"' 608 645 IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"' 609 lerr = getKey('iGeneration', iGen, tr(:) );IF(lerr) RETURN610 lerr = getKey('name', tname, tr(:) );IF(lerr) RETURN646 lerr = getKey('iGeneration', iGen, tr(:)%keys); IF(lerr) RETURN 647 lerr = getKey('name', tname, tr(:)%keys); IF(lerr) RETURN 611 648 612 649 !=== CHECK FOR ORPHAN TRACERS … … 615 652 !=== CHECK PHASES 616 653 DO iq = 1, nq; IF(iGen(iq) /= 0) CYCLE !--- Generation O only is checked 617 IF(getKey(['phases','phase '], pha, iq, tr(:) , lDisp=.FALSE.)) pha = 'g' !--- Phase654 IF(getKey(['phases','phase '], pha, iq, tr(:)%keys, lDisp=.FALSE.)) pha = 'g' !--- Phase 618 655 np = LEN_TRIM(pha); bp(iq)=' ' 619 656 DO ip = 1, np; p = pha(ip:ip); IF(INDEX(known_phases, p) == 0) bp(iq) = TRIM(bp(iq))//p; END DO … … 630 667 ! Purpose: Make sure that tracers are not repeated. 631 668 !------------------------------------------------------------------------------------------------------------------------------ 632 TYPE( keys_type), INTENT(IN) :: tr(:) !--- Tracers descriptionvector669 TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 633 670 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 634 671 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name … … 647 684 nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag 648 685 tdup(:) = '' 649 lerr = getKey('name', tname, tr ); IF(lerr) RETURN650 lerr = getKey('type', dType, tr ); IF(lerr) RETURN651 lerr = getKey('iGeneration', iGen, tr ); IF(lerr) RETURN686 lerr = getKey('name', tname, tr%keys); IF(lerr) RETURN 687 lerr = getKey('type', dType, tr%keys); IF(lerr) RETURN 688 lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN 652 689 DO iq = 1, nq 653 690 IF(dType(iq) == 'tag') CYCLE !--- Tags can be repeated … … 661 698 DO k = 1, nq 662 699 IF(.NOT.ll(k)) CYCLE !--- Skip tracers different from current one 663 IF(getKey(['phases','phase '], phase, k, tr , lDisp=.FALSE.)) phase='g'!--- Get current phases700 IF(getKey(['phases','phase '], phase, k, tr%keys, lDisp=.FALSE.)) phase='g'!--- Get current phases 664 701 IF(INDEX(phase, p) /= 0) np = np + 1 !--- One more appearance of current tracer with phase "p" 665 702 END DO … … 681 718 ! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique". 682 719 !------------------------------------------------------------------------------------------------------------------------------ 683 TYPE( keys_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracers descriptionvector684 !------------------------------------------------------------------------------------------------------------------------------ 685 TYPE( keys_type), ALLOCATABLE :: ttr(:)720 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 721 !------------------------------------------------------------------------------------------------------------------------------ 722 TYPE(trac_type), ALLOCATABLE :: ttr(:) 686 723 INTEGER, ALLOCATABLE :: i0(:), iGen(:) 687 724 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:), phase(:), parents(:), dType(:) … … 695 732 nq = SIZE(tr, DIM=1) 696 733 nt = 0 697 lerr = getKey('name', tname, tr ); IF(lerr) RETURN!--- Names of the tracers698 lerr = getKey('gen0Name', gen0N, tr ); IF(lerr) RETURN!--- Names of the tracers of first generation699 lerr = getKey('iGeneration', iGen, tr ); IF(lerr) RETURN!--- Generation number700 lerr = getKey('phases', phase, tr ); IF(lerr) RETURN!--- Phases names701 lerr = getKey('parent', parents, tr ); IF(lerr) RETURN!--- Parents names702 lerr = getKey('type', dType, tr ); IF(lerr) RETURN!--- Tracers types ('tracer' or 'tag')734 lerr = getKey('name', tname, tr%keys); IF(lerr) RETURN !--- Names of the tracers 735 lerr = getKey('gen0Name', gen0N, tr%keys); IF(lerr) RETURN !--- Names of the tracers of first generation 736 lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN !--- Generation number 737 lerr = getKey('phases', phase, tr%keys); IF(lerr) RETURN !--- Phases names 738 lerr = getKey('parent', parents, tr%keys); IF(lerr) RETURN !--- Parents names 739 lerr = getKey('type', dType, tr%keys); IF(lerr) RETURN !--- Tracers types ('tracer' or 'tag') 703 740 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS 704 741 IF(iGen(iq) /= 0) CYCLE !--- Only deal with generation 0 tracers … … 726 763 IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname(iq)) !--- <parent>_<name> for tags 727 764 ttr(it) = tr(iq) !--- Same <key>=<val> pairs 728 CALL addKey('name', nam, ttr(it)) !--- Name with possibly phase suffix 729 CALL addKey('phase', p, ttr(it)) !--- Single phase entry 765 ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix 766 ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor 767 ttr(it)%phase = p !--- Single phase entry 768 CALL addKey('name', nam, ttr(it)%keys) 769 CALL addKey('phase', p, ttr(it)%keys) 730 770 IF(lExt) THEN 731 771 parent = parents(iq); IF(iGen(iq) > 0) parent = addPhase(parent, p) 732 772 gen0Nm = gen0N(iq); IF(iGen(iq) > 0) gen0Nm = addPhase(gen0Nm, p) 733 CALL addKey('parent', parent, ttr(it)) 734 CALL addKey('gen0Name', gen0Nm, ttr(it)) 773 ttr(it)%parent = parent 774 ttr(it)%gen0Name = gen0Nm 775 CALL addKey('parent', parent, ttr(it)%keys) 776 CALL addKey('gen0Name', gen0Nm, ttr(it)%keys) 735 777 END IF 736 778 it = it+1 … … 740 782 END DO 741 783 CALL MOVE_ALLOC(FROM=ttr, TO=tr) 742 CALL delKey(['phases'], tr) !--- Remove "phases" key, useless since "phase" is defined784 CALL delKey(['phases'],tr) !--- Remove few keys entries 743 785 744 786 END FUNCTION expandPhases … … 755 797 ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END 756 798 !------------------------------------------------------------------------------------------------------------------------------ 757 TYPE(keys_type), INTENT(INOUT) :: tr(:) !--- Tracers description vector 758 !------------------------------------------------------------------------------------------------------------------------------ 759 TYPE(keys_type), ALLOCATABLE :: tr2(:) 760 INTEGER, ALLOCATABLE :: iy(:), iz(:), iGen(:) 799 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 800 !------------------------------------------------------------------------------------------------------------------------------ 801 TYPE(trac_type), ALLOCATABLE :: tr2(:) 802 INTEGER, ALLOCATABLE :: iy(:), iz(:) 803 INTEGER, ALLOCATABLE :: iGen(:) 761 804 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:) 762 805 INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k … … 764 807 ! tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler 765 808 !------------------------------------------------------------------------------------------------------------------------------ 766 lerr = getKey('iGeneration', iGen, tr ); IF(lerr) RETURN!--- Generation number809 lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN !--- Generation number 767 810 nq = SIZE(tr) 768 811 DO ip = nphases, 1, -1 769 lerr = getKey('name', tname, tr ); IF(lerr) RETURN!--- Names of the tracers of first generation812 lerr = getKey('name', tname, tr%keys); IF(lerr) RETURN !--- Names of the tracers of first generation 770 813 iq = strIdx(tname, addPhase('H2O', ip)) 771 814 IF(iq == 0) CYCLE … … 783 826 END DO 784 827 ELSE 785 lerr = getKey('gen0Name', gen0N, tr); IF(lerr) RETURN!--- Names of the tracers iq = 1828 lerr = getKey('gen0Name', gen0N, tr%keys); IF(lerr) RETURN !--- Names of the tracers iq = 1 786 829 DO jq = 1, nq !--- Loop on generation 0 tracers 787 830 IF(iGen(jq) /= 0) CYCLE !--- Skip generations /= 0 … … 805 848 LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr) 806 849 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 807 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 808 TYPE(keys_type), POINTER :: t1(:), t2(:) 850 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 851 TYPE(trac_type), POINTER :: t1(:), t2(:) 852 TYPE(keys_type), POINTER :: k1(:), k2(:) 809 853 INTEGER, ALLOCATABLE :: ixct(:), ixck(:) 810 854 INTEGER :: is, ik, ik1, ik2, nk2, i1, i2, nt2 … … 814 858 lerr = .FALSE. 815 859 keys = ['parent ', 'type ', 'iGeneration'] !--- Mandatory keys 816 t1 => sections(1)%trac(:) !--- Alias: first tracers section817 lerr = getKey('name', n1, t1); IF(lerr) RETURN !--- Names of the tracers860 t1 => sections(1)%trac(:); k1 => t1(:)%keys !--- Alias: first tracers section, corresponding keys 861 lerr = getKey('name', n1, k1); IF(lerr) RETURN !--- Names of the tracers 818 862 tr = t1 819 863 !---------------------------------------------------------------------------------------------------------------------------- … … 821 865 !---------------------------------------------------------------------------------------------------------------------------- 822 866 t2 => sections(is)%trac(:) !--- Alias: current tracers section 823 lerr = getKey('name', n2, t2); IF(lerr) RETURN !--- Names of the tracers 867 k2 => t2(:)%keys 868 lerr = getKey('name', n2, k2); IF(lerr) RETURN !--- Names of the tracers 824 869 nt2 = SIZE(t2(:), DIM=1) !--- Number of tracers in section 825 870 ixct = strIdx(n1(:), n2(:)) !--- Indexes of common tracers … … 829 874 CALL msg(n1(PACK(ixct, MASK = ixct/=0)), modname, nmax=128) !--- Display duplicates (the 128 first at most) 830 875 !-------------------------------------------------------------------------------------------------------------------------- 831 DO i2=1,nt2; tnam = TRIM( n2(i2))!=== LOOP ON COMMON TRACERS876 DO i2=1,nt2; tnam = TRIM(t2(i2)%name) !=== LOOP ON COMMON TRACERS 832 877 !-------------------------------------------------------------------------------------------------------------------------- 833 878 i1 = ixct(i2); IF(i1 == 0) CYCLE !--- Idx in t1(:) ; skip new tracers … … 836 881 s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value' 837 882 DO ik = 1, SIZE(keys) 838 lerr = getKey(keys(ik), v1, i1, t1)839 lerr = getKey(keys(ik), v2, i2, t2)883 lerr = getKey(keys(ik), v1, i1, k1) 884 lerr = getKey(keys(ik), v2, i2, k2) 840 885 lerr = v1 /= v2; IF(fmsg(TRIM(keys(ik))//TRIM(s1), modname, lerr)) RETURN 841 886 END DO 842 887 843 !=== GET THE INDICES IN tr(i2)%key (:) OF THE KEYS ALSO PRESENT IN tr(i1)%key(:)844 nk2 = SIZE( t2(i2)%key(:)) !--- Keys number in current section845 ixck = strIdx( t1(i1)%key(:), t2(i2)%key(:)) !--- Common keys indexes846 !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%key (:)847 tr(i1)%key = [ tr(i1)%key, PACK(tr(i2)%key, MASK = ixck==0)]848 tr(i1)% val = [ tr(i1)%val, PACK(tr(i2)%val, MASK = ixck==0)]888 !=== GET THE INDICES IN tr(i2)%keys%key(:) OF THE KEYS ALSO PRESENT IN tr(i1)%keys%key(:) 889 nk2 = SIZE(k2(i2)%key(:)) !--- Keys number in current section 890 ixck = strIdx(k1(i1)%key(:), k2(i2)%key(:)) !--- Common keys indexes 891 !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%keys%key(:) 892 tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)] 893 tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)] 849 894 850 895 !=== KEEP TRACK OF THE COMPONENTS NAMES: COMA-SEPARATED LIST 851 lerr = getKey('component', v1, i1, t1) 852 lerr = getKey('component', v2, i2, t2) 853 CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)) 896 lerr = getKey('component', v1, i1, k1) 897 lerr = getKey('component', v2, i2, k2) 898 tr(i1)%component = TRIM(v1)//','//TRIM(v2) 899 CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)%keys) 854 900 855 901 !=== FOR TRACERS COMMON TO PREVIOUS AND CURRENT SECTIONS: CHECK WETHER SOME KEYS HAVE DIFFERENT VALUES ; KEEP OLD ONE 856 902 DO ik2 = 1, nk2 !--- Collect the corresponding indices 857 903 ik1 = ixck(ik2); IF(ik1 == 0) CYCLE 858 IF( t1(i1)%val(ik1) == t2(i2)%val(ik2)) ixck(ik2)=0904 IF(k1(i1)%val(ik1) == k2(i2)%val(ik2)) ixck(ik2)=0 859 905 END DO 860 906 IF(ALL(ixck==0)) CYCLE !--- No identical keys with /=values => nothing to display 861 907 CALL msg('Key(s)'//TRIM(s1), modname) !--- Display the keys with /=values (names list) 862 908 DO ik2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:) 863 knam = t2(i2)%key(ik2) !--- Name of the current key909 knam = k2(i2)%key(ik2) !--- Name of the current key 864 910 ik1 = ixck(ik2) !--- Corresponding index in t1(:) 865 911 IF(ik1 == 0) CYCLE !--- New keys are skipped 866 v1 = t1(i1)%val(ik1); v2 = t2(i2)%val(ik2) !--- Key values in t1(:) and t2(:)912 v1 = k1(i1)%val(ik1); v2 = k2(i2)%val(ik2) !--- Key values in t1(:) and t2(:) 867 913 CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname) 868 914 END DO … … 879 925 LOGICAL FUNCTION cumulTracers(sections, tr, lRename) RESULT(lerr) 880 926 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 881 TYPE( keys_type), ALLOCATABLE, INTENT(OUT) :: tr(:)927 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 882 928 LOGICAL, OPTIONAL, INTENT(IN) :: lRename !--- .TRUE.: add a section suffix to identical names 883 929 CHARACTER(LEN=maxlen) :: tnam_new, modname … … 888 934 tr = [( sections(is)%trac(:), is = 1, SIZE(sections) )] !--- Concatenated tracers vector 889 935 IF(PRESENT(lRename)) THEN; IF(lRename) RETURN; END IF !--- No renaming: finished 890 lerr = getKey('name', tname, tr ); IF(lerr) RETURN!--- Names891 lerr = getKey('parent', parent, tr ); IF(lerr) RETURN!--- Parents892 lerr = getKey('component', comp, tr ); IF(lerr) RETURN!--- Component name936 lerr = getKey('name', tname, tr%keys); IF(lerr) RETURN !--- Names 937 lerr = getKey('parent', parent, tr%keys); IF(lerr) RETURN !--- Parents 938 lerr = getKey('component', comp, tr%keys); IF(lerr) RETURN !--- Component name 893 939 !---------------------------------------------------------------------------------------------------------------------------- 894 940 DO iq = 1, SIZE(tr); IF(COUNT(tname == tname(iq)) == 1) CYCLE !=== LOOP ON TRACERS 895 941 !---------------------------------------------------------------------------------------------------------------------------- 896 942 tnam_new = TRIM(tname(iq))//'_'//TRIM(comp(iq)) !--- Same with section extension 897 CALL addKey('name', tnam_new, tr(iq)) !--- Modify tracer name 943 CALL addKey('name', tnam_new, tr(iq)%keys) !--- Modify tracer name 944 tr(iq)%name = TRIM(tnam_new) !--- Modify tracer name 898 945 !-------------------------------------------------------------------------------------------------------------------------- 899 946 DO jq = 1, SIZE(tr); IF(parent(jq) /= tname(iq)) CYCLE !=== LOOP ON TRACERS PARENTS 900 947 !-------------------------------------------------------------------------------------------------------------------------- 901 CALL addKey('parent', tnam_new, tr(jq)) !--- Modify tracer name 948 CALL addKey('parent', tnam_new, tr(jq)%keys) !--- Modify tracer name 949 tr(jq)%parent = TRIM(tnam_new) !--- Modify tracer name 902 950 !-------------------------------------------------------------------------------------------------------------------------- 903 951 END DO … … 946 994 tmp = int2str([(iq, iq=1, nq)]) 947 995 ELSE 948 lerr = getKey(nam, tmp, dBase(idb)%trac(:) , lDisp=lMandatory)996 lerr = getKey(nam, tmp, dBase(idb)%trac(:)%keys, lDisp=lMandatory) 949 997 END IF 950 998 IF(lerr) THEN; lerr = lMandatory; RETURN; END IF … … 965 1013 LOGICAL FUNCTION aliasTracer(tname, trac, alias) RESULT(lerr) !=== TRACER NAMED "tname" - SCALAR 966 1014 CHARACTER(LEN=*), INTENT(IN) :: tname 967 TYPE( keys_type), TARGET, INTENT(IN) :: trac(:)968 TYPE( keys_type), POINTER, INTENT(OUT) :: alias1015 TYPE(trac_type), TARGET, INTENT(IN) :: trac(:) 1016 TYPE(trac_type), POINTER, INTENT(OUT) :: alias 969 1017 INTEGER :: it 970 1018 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 971 1019 alias => NULL() 972 lerr = getKey('name', tnames, trac(:) )1020 lerr = getKey('name', tnames, trac(:)%keys) 973 1021 it = strIdx(tnames, tname) 974 1022 lerr = it /= 0; IF(.NOT.lerr) alias => trac(it) … … 976 1024 !============================================================================================================================== 977 1025 LOGICAL FUNCTION trSubset_Indx(trac, idx, alias) RESULT(lerr) !=== TRACERS WITH INDICES "idx(:)" - VECTOR 978 TYPE( keys_type), ALLOCATABLE, INTENT(IN) :: trac(:)1026 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 979 1027 INTEGER, INTENT(IN) :: idx(:) 980 TYPE( keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:)1028 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 981 1029 alias = trac(idx) 982 1030 lerr = indexUpdate(alias) … … 984 1032 !------------------------------------------------------------------------------------------------------------------------------ 985 1033 LOGICAL FUNCTION trSubset_Name(trac, tname, alias) RESULT(lerr) !=== TRACERS NAMED "tname(:)" - VECTOR 986 TYPE( keys_type), ALLOCATABLE, INTENT(IN) :: trac(:)1034 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 987 1035 CHARACTER(LEN=*), INTENT(IN) :: tname(:) 988 TYPE( keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:)1036 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 989 1037 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 990 lerr = getKey('name', tnames, trac(:) )1038 lerr = getKey('name', tnames, trac(:)%keys) 991 1039 alias = trac(strIdx(tnames, tname)) 992 1040 lerr = indexUpdate(alias) … … 994 1042 !============================================================================================================================== 995 1043 LOGICAL FUNCTION trSubset_gen0Name(trac, gen0Nm, alias) RESULT(lerr) !=== TRACERS OF COMMON 1st GENERATION ANCESTOR 996 TYPE( keys_type), ALLOCATABLE, INTENT(IN) :: trac(:)1044 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 997 1045 CHARACTER(LEN=*), INTENT(IN) :: gen0Nm 998 TYPE( keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:)1046 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 999 1047 CHARACTER(LEN=maxlen), ALLOCATABLE :: gen0N(:) 1000 lerr = getKey('gen0Name', gen0N, trac(:) )1048 lerr = getKey('gen0Name', gen0N, trac(:)%keys) 1001 1049 alias = trac(strFind(delPhase(gen0N), gen0Nm)) 1002 1050 lerr = indexUpdate(alias) … … 1006 1054 1007 1055 !============================================================================================================================== 1008 !=== UPDATE THE INDEXES iqParent, iqDescen , nqDescen, nqChildren IN THE TRACERS DESCRIPTOR LIST "tr" ==========================1056 !=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) ========= 1009 1057 !============================================================================================================================== 1010 1058 LOGICAL FUNCTION indexUpdate(tr) RESULT(lerr) 1011 TYPE( keys_type), INTENT(INOUT) :: tr(:)1059 TYPE(trac_type), INTENT(INOUT) :: tr(:) 1012 1060 INTEGER :: iq, jq, nq, ig, nGen 1013 1061 INTEGER, ALLOCATABLE :: iqDescen(:), ix(:), iy(:) 1014 1062 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:), parent(:) 1015 1063 INTEGER, DIMENSION(SIZE(tr)) :: iqParent, iGen 1016 lerr = getKey('name', tnames, tr ); IF(lerr) RETURN!--- Names1017 lerr = getKey('parent', parent, tr ); IF(lerr) RETURN!--- Parents1064 lerr = getKey('name', tnames, tr%keys); IF(lerr) RETURN !--- Names 1065 lerr = getKey('parent', parent, tr%keys); IF(lerr) RETURN !--- Parents 1018 1066 nq = SIZE(tr) 1019 1067 1020 !=== iqParent 1068 !=== iqParent, iGeneration 1021 1069 DO iq = 1, nq; iGen(iq) = 0; jq = iq 1022 1070 iqParent(iq) = strIdx(tnames, parent(iq)) 1023 1071 DO; jq = strIdx(tnames, parent(jq)); IF(jq == 0) EXIT; iGen(iq) = iGen(iq) + 1; END DO 1024 CALL addKey('iqParent', iqParent(iq), tr(iq)) 1072 CALL addKey('iqParent', parent(iq), tr(iq)%keys) 1073 CALL addKey('iqGeneration', iGen(iq), tr(iq)%keys) 1025 1074 END DO 1026 1075 … … 1029 1078 DO iq = 1, nq 1030 1079 ix = [iq]; ALLOCATE(iqDescen(0)) 1031 CALL addKey('nqChildren', 0, tr(iq))1032 1080 DO ig = iGen(iq)+1, nGen 1033 1081 iy = find(iqParent, ix); iqDescen = [iqDescen, iy]; ix = iy 1034 1082 IF(ig /= iGen(iq)+1) CYCLE 1035 CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)) 1083 CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)%keys) 1084 tr(iq)%nqChildren = SIZE(iqDescen) 1036 1085 END DO 1037 CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)) 1038 CALL addKey('nqDescen', SIZE(iqDescen), tr(iq)) 1086 CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)%keys) 1087 CALL addKey('nqDescen', SIZE(iqDescen), tr(iq)%keys) 1088 tr(iq)%iqDescen = iqDescen 1089 tr(iq)%nqDescen = SIZE(iqDescen) 1039 1090 DEALLOCATE(iqDescen) 1040 1091 END DO … … 1044 1095 1045 1096 !============================================================================================================================== 1046 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS ISOTOPES CLASSES IN "isot(:)%name":====1047 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)% name"====1097 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ==== 1098 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ==== 1048 1099 !=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ==== 1049 1100 !=== NOTES: ==== 1050 1101 !=== * Most of the "isot" components have been defined in the calling routine (processIsotopes): ==== 1051 !=== name, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:)====1102 !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:) ==== 1052 1103 !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== 1053 1104 !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== … … 1058 1109 LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr) 1059 1110 CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name 1060 TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field % namemust be defined!)1111 TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field %parent must be defined!) 1061 1112 LOGICAL :: lFound 1062 1113 INTEGER :: is, iis, it, idb, ndb, nb0 1063 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) , tname(:), iname(:)1114 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) 1064 1115 CHARACTER(LEN=maxlen) :: modname 1065 TYPE( keys_type), POINTER ::t1116 TYPE(trac_type), POINTER :: tt(:), t 1066 1117 TYPE(dataBase_type), ALLOCATABLE :: tdb(:) 1067 1118 modname = 'readIsotopesFile' 1068 1119 1069 1120 !--- THE INPUT FILE MUST BE PRESENT 1070 INQUIRE(FILE=TRIM(fnam), EXIST=lFound) 1071 lerr = .NOT.lFound 1072 CALL msg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr) 1073 IF(lerr) RETURN 1074 1075 !--- READ THE FILE SECTIONS, ONE EACH ISOTOPES CLASS (FIEDL %name) 1121 INQUIRE(FILE=TRIM(fnam), EXIST=lFound); lerr = .NOT.lFound 1122 IF(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr)) RETURN 1123 1124 !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER 1076 1125 nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index 1077 lerr = readSections(fnam,strStack(isot(:)% name,'|')); IF(lerr) RETURN !--- Read sections, one each isotopes class %name1126 lerr = readSections(fnam,strStack(isot(:)%parent,'|')); IF(lerr) RETURN !--- Read sections, one each parent tracer 1078 1127 ndb = SIZE(dBase, DIM=1) !--- Current database size 1079 1128 DO idb = nb0, ndb … … 1081 1130 1082 1131 !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION 1083 ! lerr = addKeysFromDef(dBase(idb)%trac, 'params'); IF(lerr) RETURN 1132 CALL addKeysFromDef(dBase(idb)%trac, 'params') 1084 1133 1085 1134 !--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER 1086 lerr = subDefault(dBase(idb)%trac, 'params', .TRUE.); IF(lerr) RETURN 1135 CALL subDefault(dBase(idb)%trac, 'params', .TRUE.) 1136 1137 tt => dBase(idb)%trac 1087 1138 1088 1139 !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR 1089 lerr = getKey('name', tname, dBase(idb)%trac); IF(lerr) RETURN1090 lerr = getKey('name', iname, isot(iis)%keys); IF(lerr) RETURN1091 1140 DO it = 1, SIZE(dBase(idb)%trac) 1092 1141 t => dBase(idb)%trac(it) 1093 is = strIdx(i name, tname(it)) !--- Index in "iname(:)" of isotope "tname(it)"1142 is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name" 1094 1143 IF(is == 0) CYCLE 1095 lerr = ANY(reduceExpr(t% val, vals)); IF(lerr) RETURN!--- Reduce expressions ; detect non-numerical elements1096 isot(iis)%keys(is)%key = t%key 1144 lerr = ANY(reduceExpr(t%keys%val, vals)); IF(lerr) RETURN !--- Reduce expressions ; detect non-numerical elements 1145 isot(iis)%keys(is)%key = t%keys%key 1097 1146 isot(iis)%keys(is)%val = vals 1098 1147 END DO 1099 1148 1100 1149 !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED) 1101 lerr = checkList(i name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &1150 lerr = checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], & 1102 1151 'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing') 1103 1152 IF(lerr) RETURN … … 1112 1161 1113 1162 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) 1114 CALL get_in('ok_iso_verif', isot(strIdx(i name, 'H2O'))%check, .FALSE.)1163 CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.) 1115 1164 1116 1165 lerr = dispIsotopes() … … 1122 1171 INTEGER :: ik, nk, ip, it, nt 1123 1172 CHARACTER(LEN=maxlen) :: prf 1124 CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) , tname(:)1173 CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) 1125 1174 CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname) 1126 DO ip = 1, SIZE(isot) !--- Loop on isotopes classes 1127 IF(SIZE(isot(ip)%keys) == 0) CYCLE 1175 DO ip = 1, SIZE(isot) !--- Loop on parents tracers 1128 1176 nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope 1129 1177 nt = SIZE(isot(ip)%keys) !--- Number of isotopes … … 1131 1179 ALLOCATE(ttl(nk+2), val(nt,nk+1)) 1132 1180 ttl(1:2) = ['it ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names 1133 lerr = getKey('name', tname, isot(ip)%keys); IF(lerr) RETURN 1134 val(:,1) = tname !--- Values table 1st column: isotopes names 1181 val(:,1) = isot(ip)%keys(:)%name !--- Values table 1st column: isotopes names 1135 1182 DO ik = 1, nk 1136 1183 DO it = 1, nt … … 1152 1199 !=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: === 1153 1200 !=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). === 1154 !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS (defined by "keys(:)") === 1155 !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) /!\ DISABLED FUNCTION /!\ === 1156 !============================================================================================================================== 1157 LOGICAL FUNCTION processIsotopes(keys, isot, iClasses) RESULT(lerr) 1158 TYPE(keys_type), TARGET, OPTIONAL, INTENT(INOUT) :: keys(:) 1159 TYPE(isot_type), TARGET, ALLOCATABLE, OPTIONAL, INTENT(OUT) :: isot(:) 1160 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: iClasses(:) 1161 CHARACTER(LEN=maxlen), ALLOCATABLE :: str1(:), str2(:) !--- Temporary storage 1162 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:), iCla(:) 1163 CHARACTER(LEN=maxlen) :: iClass, modname 1164 CHARACTER(LEN=1) :: ph !--- Phase 1165 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 1166 INTEGER, ALLOCATABLE :: iGen(:) 1167 INTEGER :: ic, ip, iq, ii, it, iz 1168 TYPE(isot_type), POINTER :: i1 1169 TYPE(keys_type), POINTER :: k(:) 1201 !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS === 1202 !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) === 1203 !=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. === 1204 !============================================================================================================================== 1205 LOGICAL FUNCTION processIsotopes(iNames) RESULT(lerr) 1206 CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN) :: iNames(:) 1207 CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage 1208 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:) 1209 CHARACTER(LEN=maxlen) :: iName, modname 1210 CHARACTER(LEN=1) :: ph !--- Phase 1211 INTEGER, ALLOCATABLE :: iGen(:) 1212 INTEGER :: ic, ip, iq, it, iz 1213 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 1214 TYPE(trac_type), POINTER :: t(:), t1 1215 TYPE(isot_type), POINTER :: i 1170 1216 1171 1217 lerr = .FALSE. 1172 1218 modname = 'readIsotopesFile' 1173 k => tracers; IF(PRESENT(keys )) k => keys 1174 lerr = getKey('name', tname, k); IF(lerr) RETURN !--- Names 1175 lerr = getKey('parent', parent, k); IF(lerr) RETURN !--- Parents 1176 lerr = getKey('type', dType, k); IF(lerr) RETURN !--- Tracer type 1177 lerr = getKey('phase', phase, k); IF(lerr) RETURN !--- Phase 1178 lerr = getKey('gen0Name', gen0N, k); IF(lerr) RETURN !--- 1st generation ancestor name 1179 lerr = getKey('iGeneration', iGen, k); IF(lerr) RETURN !--- Generation number 1180 1181 !--- INITIALIZATION IF ISOTOPES-SPECIFIC KEYS (MUST BE DEFINED EVEN WITHOUT ISOTOPES) 1182 DO iq = 1, SIZE(k) 1183 CALL addKey('iso_iGroup',0, k(iq)) !--- Family idx in list "isotopes(:)%parent" 1184 CALL addKey('iso_iName', 0, k(iq)) !--- Isotope idx in effective isotopes list 1185 CALL addKey('iso_iZone', 0, k(iq)) !--- Tagging zone idx in effective zones list 1186 CALL addKey('iso_iPhas', 0, k(iq)) !--- Phase idx in effective phases list 1187 END DO 1219 1220 t => tracers 1221 1222 lerr = getKey('name', tname, t%keys); IF(lerr) RETURN !--- Names 1223 lerr = getKey('parent', parent, t%keys); IF(lerr) RETURN !--- Parents 1224 lerr = getKey('type', dType, t%keys); IF(lerr) RETURN !--- Tracer type 1225 lerr = getKey('phase', phase, t%keys); IF(lerr) RETURN !--- Phase 1226 lerr = getKey('gen0Name', gen0N, t%keys); IF(lerr) RETURN !--- 1st generation ancestor name 1227 lerr = getKey('iGeneration', iGen, t%keys); IF(lerr) RETURN !--- Generation number 1188 1228 1189 1229 !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES 1190 iCla= PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1)1191 CALL strReduce( iCla)1192 1193 !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "i Classes" ARE AVAILABLE OR NOT1194 IF(PRESENT(i Classes)) THEN1195 DO it = 1, SIZE(i Classes)1196 lerr = ALL( iCla /= iClasses(it))1197 IF(fmsg('No isotopes class "'//TRIM(i Classes(it))//'" found among tracers', modname, lerr)) RETURN1230 p = PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1) 1231 CALL strReduce(p, nbIso) 1232 1233 !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT 1234 IF(PRESENT(iNames)) THEN 1235 DO it = 1, SIZE(iNames) 1236 lerr = ALL(p /= iNames(it)) 1237 IF(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, lerr)) RETURN 1198 1238 END DO 1199 iCla = iClasses1239 p = iNames; nbIso = SIZE(p) 1200 1240 END IF 1201 nbIso = SIZE(iCla) 1202 1203 !--- USE THE ARGUMENT "isot" TO STORE THE ISOTOPIC DATABASE OR THE LOCAL VECTOR "isotopes" 1204 IF(PRESENT(isot)) THEN 1205 ALLOCATE( isot(nbIso)) 1206 ELSE 1207 IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) 1208 ALLOCATE(isotopes(nbIso)) 1209 END IF 1241 IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) 1242 ALLOCATE(isotopes(nbIso)) 1243 1210 1244 IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED 1211 1245 1212 1246 !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES 1213 DO ic = 1, nbIso !--- Loop on isotopes classes 1214 IF( PRESENT(isot)) i1 => isot (ic) 1215 IF(.NOT.PRESENT(isot)) i1 => isotopes(ic) 1216 iClass = iCla(ic) !--- Current isotopes class name (parent tracer name) 1217 i1%name = iClass 1218 1219 !=== Isotopes children of tracer "iClass": mask, names, number (same for each phase of "iClass") 1220 ll = dType=='tracer' .AND. delPhase(parent) == iClass .AND. phase == 'g' 1221 str1 = PACK(delPhase(tname), MASK = ll) !--- Effectively found isotopes of "iClass" 1222 i1%niso = SIZE(str1) !--- Number of "effectively found isotopes of "iname" 1223 ALLOCATE(i1%keys(i1%niso)) 1224 DO it = 1, i1%niso; CALL addKey('name', str1(it), i1%keys(it)); END DO 1225 1226 !=== Geographic tagging tracers descending on tracer "iClass": mask, names, number 1227 ll = dType=='tag' .AND. delPhase(gen0N) == iClass .AND. iGen == 2 1228 i1%zone = PACK(strTail(tname, '_', .TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 1229 CALL strReduce(i1%zone) 1230 i1%nzone = SIZE(i1%zone) !--- Tagging zones number for isotopes category "iClass" 1231 1232 !=== Geographic tracers of the isotopes children of tracer "iClass" (same for each phase of "iClass") 1247 isotopes(:)%parent = p 1248 DO ic = 1, SIZE(p) !--- Loop on isotopes classes 1249 i => isotopes(ic) 1250 iname = i%parent !--- Current isotopes class name (parent tracer name) 1251 1252 !=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname") 1253 ll = dType=='tracer' .AND. delPhase(parent) == iname .AND. phase == 'g' 1254 str = PACK(delPhase(tname), MASK = ll) !--- Effectively found isotopes of "iname" 1255 i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" 1256 ALLOCATE(i%keys(i%niso)) 1257 FORALL(it = 1:i%niso) i%keys(it)%name = str(it) 1258 1259 !=== Geographic tagging tracers descending on tracer "iname": mask, names, number 1260 ll = dType=='tag' .AND. delPhase(gen0N) == iname .AND. iGen == 2 1261 i%zone = PACK(strTail(tname,'_',.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 1262 CALL strReduce(i%zone) 1263 i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname" 1264 1265 !=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname") 1233 1266 ! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers) 1234 str 2= PACK(delPhase(tname), MASK=ll)1235 CALL strReduce(str 2)1236 i 1%ntiso = i1%niso + SIZE(str2)!--- Number of isotopes + their geographic tracers [ntiso]1237 ALLOCATE(i 1%trac(i1%ntiso))1238 DO it = 1, i1%niso; i1%trac(it) = str1(it); END DO1239 DO it = i1%niso+1, i1%ntiso; i1%trac(it) = str2(it-i1%niso); END DO1240 1241 !=== Phases for tracer "i Class"1242 i 1%phase = ''1243 DO ip = 1, nphases; ph = known_phases(ip:ip); IF( ANY(tname == addPhase(iClass, ph))) i1%phase = TRIM(i1%phase)//ph; END DO1244 i 1%nphas = LEN_TRIM(i1%phase) !--- Equal to "nqo" for water1267 str = PACK(delPhase(tname), MASK=ll) 1268 CALL strReduce(str) 1269 i%ntiso = i%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntiso] 1270 ALLOCATE(i%trac(i%ntiso)) 1271 FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name 1272 FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso) 1273 1274 !=== Phases for tracer "iname" 1275 i%phase = '' 1276 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) i%phase = TRIM(i%phase)//ph; END DO 1277 i%nphas = LEN_TRIM(i%phase) !--- Equal to "nqo" for water 1245 1278 1246 1279 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) 1247 DO iq = 1, SIZE(tracers) 1248 ii = strIdx(i1%trac, strHead(delPhase(tname(iq)), '_', .TRUE.)) 1249 iz = strIdx(i1%zone, strTail( tname(iq), '_', .TRUE.)) 1250 ip = INDEX(i1%phase, TRIM(phase(iq) )) 1251 IF(delPhase(gen0N(iq)) /= iClass .OR. iGen(iq) == 0) CYCLE !--- Only deal with tracers descending on "iClass" 1252 CALL addKey('iso_iGroup',ic, k(iq)) !--- Family idx in list "isotopes(:)%name" 1253 CALL addKey('iso_iName', ii, k(iq)) !--- Isotope idx in effective isotopes list 1254 CALL addKey('iso_iZone', iz, k(iq)) !--- Tagging zone idx in effective zones list 1255 CALL addKey('iso_iPhas', ip, k(iq)) !--- Phase idx in effective phases list 1256 IF(iGen(iq) /= 2) CALL addKey('iso_iZone', 0, k(iq)) !--- Skip possible generation 1 tagging tracers 1280 DO iq = 1, SIZE(t) 1281 t1 => tracers(iq) 1282 IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname" 1283 t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" 1284 t1%iso_iName = strIdx(i%trac, strHead(delPhase(t1%name),'_',.TRUE.)) !--- Current isotope idx in effective isotopes list 1285 t1%iso_iZone = strIdx(i%zone, strTail(t1%name, '_',.TRUE.)) !--- Current isotope zone idx in effective zones list 1286 t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list 1287 IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 tagging tracers 1257 1288 END DO 1258 1289 1259 1290 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 1260 1291 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 1261 i 1%iqIsoPha = RESHAPE( [( (strIdx(tname, addPhase(i1%trac(it),i1%phase(ip:ip))), it=1, i1%ntiso), ip=1, i1%nphas)], &1262 [i 1%ntiso, i1%nphas] )1292 i%iqIsoPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], & 1293 [i%ntiso, i%nphas] ) 1263 1294 !=== Table used to get iq (index in dyn array, size nqtot) from the water and isotope and phase indexes ; the full isotopes list 1264 1295 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 1265 i 1%iqWIsoPha = RESHAPE( [( [strIdx(tname, addPhase('H2O', i1%phase(ip:ip))), i1%iqIsoPha(:,ip)], ip=1, i1%nphas)], &1266 [1+i 1%ntiso, i1%nphas] )1296 i%iqWIsoPha = RESHAPE( [( [strIdx(t%name, addPhase('H2O',i%phase(ip:ip))), i%iqIsoPha(:,ip)], ip=1,i%nphas)], & 1297 [1+i%ntiso, i%nphas] ) 1267 1298 !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes 1268 i 1%itZonIso = RESHAPE( [( (strIdx(i1%trac(:), TRIM(i1%trac(it))//'_'//TRIM(i1%zone(iz))), iz=1, i1%nzone), it=1, i1%niso )], &1269 [i 1%nzone, i1%niso] )1299 i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], & 1300 [i%nzone, i%niso] ) 1270 1301 END DO 1271 1302 1272 !=== READ PHYSICAL PARAMETERS FROM isoFile FILE (COMMENTED => DISABLED) 1273 ! IF( PRESENT(isot)) lerr = readIsotopesFile(isoFile, isot) 1274 ! IF(.NOT.PRESENT(isot)) lerr = readIsotopesFile(isoFile, isotopes) 1275 ! IF(lerr) RETURN 1303 !=== READ PHYSICAL PARAMETERS FROM isoFile FILE 1304 ! lerr = readIsotopesFile(isoFile, isotopes); IF(lerr) RETURN! on commente pour ne pas chercher isotopes_params.def 1276 1305 1277 1306 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) … … 1282 1311 1283 1312 !=== SELECT WATER ISOTOPES CLASS OR, IF UNFOUND, THE FIRST ISOTOPES CLASS 1284 IF(isoSelect('H2O', lVerbose=.TRUE.)) THEN 1285 iH2O = ixIso 1286 ELSE 1287 lerr = isoSelect(1, lVerbose=.TRUE.) 1288 END IF 1313 IF(isoSelect('H2O', .TRUE.)) THEN; iH2O = ixIso; ELSE; lerr = isoSelect(1, .TRUE.); END IF 1289 1314 1290 1315 CONTAINS … … 1294 1319 !------------------------------------------------------------------------------------------------------------------------------ 1295 1320 INTEGER :: ix, it, ip, np, iz, nz, npha, nzon 1321 TYPE(isot_type), POINTER :: i 1296 1322 DO ix = 1, nbIso 1297 IF( PRESENT(isot)) i1 => isot (ix) 1298 IF(.NOT.PRESENT(isot)) i1 => isotopes(ix) 1323 i => isotopes(ix) 1299 1324 !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases 1300 DO it = 1, i 1%ntiso; npha = i1%nphas1301 np = SUM([(COUNT(t name(:) == addPhase(i1%trac(it), i1%phase(ip:ip))), ip=1, npha)])1325 DO it = 1, i%ntiso; npha = i%nphas 1326 np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, npha)]) 1302 1327 lerr = np /= npha 1303 CALL msg(TRIM(int2str(np))// ' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i1%trac(it)), modname, lerr)1328 CALL msg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr) 1304 1329 IF(lerr) RETURN 1305 1330 END DO 1306 DO it = 1, i 1%niso; nzon = i1%nzone1307 nz = SUM([(COUNT(i 1%trac == TRIM(i1%trac(it))//'_'//i1%zone(iz)), iz=1, nzon)])1331 DO it = 1, i%niso; nzon = i%nzone 1332 nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, nzon)]) 1308 1333 lerr = nz /= nzon 1309 CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i 1%trac(it)), modname, lerr)1334 CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i%trac(it)), modname, lerr) 1310 1335 IF(lerr) RETURN 1311 1336 END DO … … 1320 1345 !============================================================================================================================== 1321 1346 !=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED 1322 ! Single generic "isoSelect" routine, using the predefined index of the class(fast version) or its name (first call).1323 !============================================================================================================================== 1324 LOGICAL FUNCTION isoSelectByName(i Class, isot, lVerbose) RESULT(lerr)1347 ! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call). 1348 !============================================================================================================================== 1349 LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr) 1325 1350 IMPLICIT NONE 1326 CHARACTER(LEN=*), INTENT(IN) :: iClass 1327 TYPE(isot_type), OPTIONAL, TARGET, INTENT(IN) :: isot(:) 1328 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1329 TYPE(isot_type), POINTER :: iso(:) 1351 CHARACTER(LEN=*), INTENT(IN) :: iName 1352 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1330 1353 INTEGER :: iIso 1331 1354 LOGICAL :: lV 1332 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1333 iso => isotopes; IF(PRESENT(isot)) iso => isot 1334 iIso = strIdx(iso(:)%name, iClass) 1355 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1356 iIso = strIdx(isotopes(:)%parent, iName) 1335 1357 lerr = iIso == 0 1336 1358 IF(lerr) THEN 1337 1359 niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE. 1338 CALL msg('no isotope family named "'//TRIM(i Class)//'"', ll=lV)1360 CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV) 1339 1361 RETURN 1340 1362 END IF 1341 lerr = isoSelectByIndex(iIso, iso,lV)1363 lerr = isoSelectByIndex(iIso, lV) 1342 1364 END FUNCTION isoSelectByName 1343 1365 !============================================================================================================================== 1344 LOGICAL FUNCTION isoSelectByIndex(iIso, isot,lVerbose) RESULT(lerr)1366 LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr) 1345 1367 IMPLICIT NONE 1346 INTEGER, INTENT(IN) :: iIso 1347 TYPE(isot_type), TARGET, OPTIONAL, INTENT(INOUT) :: isot(:) 1348 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1349 TYPE(isot_type), POINTER :: i(:) 1368 INTEGER, INTENT(IN) :: iIso 1369 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1350 1370 LOGICAL :: lV 1351 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1352 i => isotopes; IF(PRESENT(isot)) i => isot 1371 lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose 1353 1372 lerr = .FALSE. 1354 1373 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK 1355 lerr = iIso<=0 .OR. iIso>SIZE(i )1374 lerr = iIso<=0 .OR. iIso>SIZE(isotopes) 1356 1375 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '& 1357 //TRIM(int2str(SIZE(i )))//'"', ll = lerr .AND. lV)1376 //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV) 1358 1377 IF(lerr) RETURN 1359 1378 ixIso = iIso !--- Update currently selected family index 1360 isotope => i (ixIso)!--- Select corresponding component1379 isotope => isotopes(ixIso) !--- Select corresponding component 1361 1380 isoKeys => isotope%keys; niso = isotope%niso 1362 1381 isoName => isotope%trac; ntiso = isotope%ntiso … … 1365 1384 itZonIso => isotope%itZonIso; isoCheck = isotope%check 1366 1385 iqIsoPha => isotope%iqIsoPha 1367 iqWIsoPha => isotope%iqWIsoPha1386 iqWIsoPha => isotope%iqWIsoPha 1368 1387 END FUNCTION isoSelectByIndex 1369 1388 !============================================================================================================================== … … 1509 1528 !=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. =========================== 1510 1529 !============================================================================================================================== 1511 LOGICAL FUNCTION addKeysFromDef(t, tr0) RESULT(lerr)1512 TYPE( keys_type), ALLOCATABLE, INTENT(INOUT) :: t(:)1530 SUBROUTINE addKeysFromDef(t, tr0) 1531 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:) 1513 1532 CHARACTER(LEN=*), INTENT(IN) :: tr0 1514 1533 !------------------------------------------------------------------------------------------------------------------------------ 1515 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)1516 1534 CHARACTER(LEN=maxlen) :: val 1517 1535 INTEGER :: ik, jd 1518 lerr = getKey('name', tname, t); IF(lerr) RETURN 1519 jd = strIdx(tname(:), tr0) 1536 jd = strIdx(t%name, tr0) 1520 1537 IF(jd == 0) RETURN 1521 DO ik = 1, SIZE(t(jd)%key )1522 CALL get_in(t(jd)%key (ik), val, '*none*')1523 IF(val /= '*none*') CALL addKey(t(jd)%key (ik), val, t(jd), .TRUE.)1538 DO ik = 1, SIZE(t(jd)%keys%key) 1539 CALL get_in(t(jd)%keys%key(ik), val, '*none*') 1540 IF(val /= '*none*') CALL addKey(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) 1524 1541 END DO 1525 END FUNCTIONaddKeysFromDef1542 END SUBROUTINE addKeysFromDef 1526 1543 !============================================================================================================================== 1527 1544 … … 1533 1550 INTEGER, INTENT(IN) :: itr 1534 1551 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1535 TYPE( keys_type), INTENT(INOUT) :: ky(:)1552 TYPE(trac_type), INTENT(INOUT) :: ky(:) 1536 1553 !------------------------------------------------------------------------------------------------------------------------------ 1537 1554 CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:) … … 1539 1556 INTEGER :: iky 1540 1557 IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range 1541 ll = [( ALL(keyn/=ky(itr)%key (iky)), iky=1, SIZE(ky(itr)%key) )]1542 k = PACK(ky(itr)%key , MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%key)1543 v = PACK(ky(itr)% val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%val)1558 ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )] 1559 k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key) 1560 v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val) 1544 1561 END SUBROUTINE delKey_1 1545 1562 !============================================================================================================================== 1546 1563 SUBROUTINE delKey(keyn, ky) 1547 1564 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1548 TYPE( keys_type), INTENT(INOUT) :: ky(:)1565 TYPE(trac_type), INTENT(INOUT) :: ky(:) 1549 1566 !------------------------------------------------------------------------------------------------------------------------------ 1550 1567 INTEGER :: iky … … 1594 1611 !=== TRY TO GET THE KEY NAMED "key" FOR THE "itr"th TRACER IN: === 1595 1612 !=== * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE: === 1596 !=== * IN INTERNAL TRACERS DATABASE "tracers(:) " (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")===1613 !=== * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)") === 1597 1614 !=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER: === 1598 1615 !=== * A SCALAR === … … 1660 1677 lerr = .TRUE. 1661 1678 IF(lerr .AND. PRESENT(ky)) val = fgetKey(ky) !--- "ky" 1662 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:) )!--- "tracers"1679 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys) !--- "tracers" 1663 1680 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 1664 1681 IF(lerr .AND. PRESENT(def)) THEN … … 1765 1782 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1766 1783 val = str2int(svals) 1767 lerr = ANY(val == -HUGE(1)) .AND. sval /= ''1784 lerr = ANY(val == -HUGE(1)) 1768 1785 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1769 1786 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 1785 1802 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1786 1803 val = str2real(svals) 1787 lerr = ANY(val == -HUGE(1.)) .AND. sval /= ''1804 lerr = ANY(val == -HUGE(1.)) 1788 1805 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1789 1806 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 1806 1823 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1807 1824 ivals = str2bool(svals) 1808 lerr = ANY(ivals == -1) .AND. sval /= ''1825 lerr = ANY(ivals == -1) 1809 1826 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1810 1827 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 1843 1860 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1844 1861 val = str2int(svals) 1845 lerr = ANY(val == -HUGE(1)) .AND. sval /= ''1862 lerr = ANY(val == -HUGE(1)) 1846 1863 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1847 1864 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 1864 1881 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1865 1882 val = str2real(svals) 1866 lerr = ANY(val == -HUGE(1.)) .AND. sval /= ''1883 lerr = ANY(val == -HUGE(1.)) 1867 1884 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1868 1885 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 1886 1903 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1887 1904 ivals = str2bool(svals) 1888 lerr = ANY(ivals == -1) .AND. sval /= ''1905 lerr = ANY(ivals == -1) 1889 1906 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1890 1907 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 1893 1910 !============================================================================================================================== 1894 1911 !============================================================================================================================== 1895 LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1896 CHARACTER(LEN=*), INTENT(IN) :: keyn 1897 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1898 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1899 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1900 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1901 lerr = getKeyByIndex_smmm([keyn], val, ky, def, lDisp) 1912 LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1913 CHARACTER(LEN=*), INTENT(IN) :: keyn 1914 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1915 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1916 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1917 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1918 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1919 lerr = getKeyByIndex_smmm([keyn], val, ky, nam, def, lDisp) 1902 1920 END FUNCTION getKeyByIndex_s1mm 1903 1921 !============================================================================================================================== 1904 LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1905 CHARACTER(LEN=*), INTENT(IN) :: keyn 1906 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1907 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1908 INTEGER, OPTIONAL, INTENT(IN) :: def 1909 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1910 lerr = getKeyByIndex_immm([keyn], val, ky, def, lDisp) 1922 LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1923 CHARACTER(LEN=*), INTENT(IN) :: keyn 1924 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1925 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1926 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1927 INTEGER, OPTIONAL, INTENT(IN) :: def 1928 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1929 lerr = getKeyByIndex_immm([keyn], val, ky, nam, def, lDisp) 1911 1930 END FUNCTION getKeyByIndex_i1mm 1912 1931 !============================================================================================================================== 1913 LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1914 CHARACTER(LEN=*), INTENT(IN) :: keyn 1915 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1916 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1917 REAL, OPTIONAL, INTENT(IN) :: def 1918 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1919 lerr = getKeyByIndex_rmmm([keyn], val, ky, def, lDisp) 1932 LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1933 CHARACTER(LEN=*), INTENT(IN) :: keyn 1934 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1935 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1936 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1937 REAL, OPTIONAL, INTENT(IN) :: def 1938 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1939 lerr = getKeyByIndex_rmmm([keyn], val, ky, nam, def, lDisp) 1920 1940 END FUNCTION getKeyByIndex_r1mm 1921 1941 !============================================================================================================================== 1922 LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1923 CHARACTER(LEN=*), INTENT(IN) :: keyn 1924 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1925 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1926 LOGICAL, OPTIONAL, INTENT(IN) :: def 1927 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1928 lerr = getKeyByIndex_lmmm([keyn], val, ky, def, lDisp) 1942 LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1943 CHARACTER(LEN=*), INTENT(IN) :: keyn 1944 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1945 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1946 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1947 LOGICAL, OPTIONAL, INTENT(IN) :: def 1948 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1949 lerr = getKeyByIndex_lmmm([keyn], val, ky, nam, def, lDisp) 1929 1950 END FUNCTION getKeyByIndex_l1mm 1930 1951 !============================================================================================================================== 1931 1952 !============================================================================================================================== 1932 LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, def, lDisp) RESULT(lerr) 1933 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1934 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1935 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1936 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1937 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1953 LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1954 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1955 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1956 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1957 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1958 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1959 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1938 1960 !------------------------------------------------------------------------------------------------------------------------------ 1939 1961 CHARACTER(LEN=maxlen) :: s 1962 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 1940 1963 INTEGER :: iq, nq(3), k 1941 1964 LOGICAL :: lD, l(3) … … 1944 1967 lerr = .TRUE. 1945 1968 IF(PRESENT(ky)) THEN; val = fgetKey(ky) !--- "ky" 1946 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:) )!--- "tracers"1969 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:)%keys) !--- "tracers" 1947 1970 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 1948 1971 END IF 1949 IF(.NOT.lerr) RETURN1972 IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF 1950 1973 IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF 1951 1974 … … 1968 1991 INTEGER :: iq 1969 1992 lerr = SIZE(ky) == 0; IF(lerr) RETURN 1993 tname = ky%name 1970 1994 val = [(fgetKeyIdx(iq, keyn(:), ky, ler(iq)), iq = 1, SIZE(ky))] 1971 1995 lerr = ANY(ler) … … 1974 1998 END FUNCTION getKeyByIndex_smmm 1975 1999 !============================================================================================================================== 1976 LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, def, lDisp) RESULT(lerr) 1977 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1978 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1979 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1980 INTEGER, OPTIONAL, INTENT(IN) :: def 1981 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2000 LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2001 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2002 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 2003 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2004 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2005 INTEGER, OPTIONAL, INTENT(IN) :: def 2006 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1982 2007 !------------------------------------------------------------------------------------------------------------------------------ 1983 2008 CHARACTER(LEN=maxlen) :: s 1984 2009 CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) 1985 2010 LOGICAL, ALLOCATABLE :: ll(:) 1986 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, int2str(def), lDisp)1987 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp)2011 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, int2str(def), lDisp) 2012 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) 1988 2013 IF(lerr) RETURN 1989 2014 val = str2int(svals) 1990 ll = val == -HUGE(1) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 1991 lerr = ANY(ll); IF(.NOT.lerr) RETURN 1992 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2015 ll = val == -HUGE(1) 2016 lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF 1993 2017 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not' 1994 2018 CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname, lerr) 2019 IF(.NOT.lerr .AND. PRESENT(nam)) nam = tname 1995 2020 END FUNCTION getKeyByIndex_immm 1996 2021 !============================================================================================================================== 1997 LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, def, lDisp) RESULT(lerr) 1998 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1999 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2000 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2001 REAL, OPTIONAL, INTENT(IN) :: def 2002 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2022 LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2023 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2024 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2025 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2026 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2027 REAL, OPTIONAL, INTENT(IN) :: def 2028 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2003 2029 !------------------------------------------------------------------------------------------------------------------------------ 2004 2030 CHARACTER(LEN=maxlen) :: s 2005 2031 CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) 2006 2032 LOGICAL, ALLOCATABLE :: ll(:) 2007 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, real2str(def), lDisp)2008 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp)2033 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, real2str(def), lDisp) 2034 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) 2009 2035 IF(lerr) RETURN 2010 2036 val = str2real(svals) 2011 ll = val == -HUGE(1.) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2012 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2013 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2037 ll = val == -HUGE(1.) 2038 lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF 2014 2039 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not a' 2015 2040 CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname) 2016 2041 END FUNCTION getKeyByIndex_rmmm 2017 2042 !============================================================================================================================== 2018 LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, def, lDisp) RESULT(lerr) 2019 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2020 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2021 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2022 LOGICAL, OPTIONAL, INTENT(IN) :: def 2023 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2043 LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2044 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2045 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2046 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2047 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2048 LOGICAL, OPTIONAL, INTENT(IN) :: def 2049 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2024 2050 !------------------------------------------------------------------------------------------------------------------------------ 2025 2051 CHARACTER(LEN=maxlen) :: s … … 2027 2053 LOGICAL, ALLOCATABLE :: ll(:) 2028 2054 INTEGER, ALLOCATABLE :: ivals(:) 2029 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, bool2str(def), lDisp)2030 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp)2055 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, bool2str(def), lDisp) 2056 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) 2031 2057 IF(lerr) RETURN 2032 2058 ivals = str2bool(svals) 2033 ll = ivals == -1 .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2034 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2035 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2059 ll = ivals == -1 2060 lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; IF(PRESENT(nam)) nam = tname; RETURN; END IF 2036 2061 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' 2037 2062 CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname) 2038 IF(.NOT.lerr) val = ivals == 12039 2063 END FUNCTION getKeyByIndex_lmmm 2040 2064 !============================================================================================================================== … … 2047 2071 !=== TRY TO GET THE KEY NAMED "key" FOR THE TRACER NAMED "tname" IN: === 2048 2072 !=== * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE: === 2049 !=== * IN INTERNAL TRACERS DATABASE "tracers(:) " (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")===2073 !=== * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)") === 2050 2074 !=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER: === 2051 2075 !=== * A SCALAR === … … 2109 2133 tnam = strHead(delPhase(tname),'_',.TRUE.) !--- Remove phase and tag 2110 2134 IF(lerr .AND. PRESENT(ky)) val = fgetKey(ky) !--- "ky" 2111 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:) )!--- "tracers"2135 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys) !--- "tracers" 2112 2136 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 2113 2137 IF(lerr .AND. PRESENT(def)) THEN … … 2121 2145 CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val) 2122 2146 TYPE(keys_type), INTENT(IN) :: ky(:) 2123 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname_all(:)2124 lerr = SIZE(ky) == 0;IF(lerr) RETURN2125 lerr = getKey('name', tname_all, ky); IF(lerr) RETURN2126 val = fgetKeyIdx(strIdx(tname_all, tname), [keyn], ky, lerr)2127 IF(lerr) val = fgetKeyIdx(strIdx(tname_all, tnam ), [keyn], ky, lerr) 2147 lerr = SIZE(ky) == 0 2148 IF(lerr) RETURN 2149 val = fgetKeyIdx(strIdx(ky%name, tname), [keyn], ky, lerr) 2150 IF(lerr) val = fgetKeyIdx(strIdx(ky%name, tnam ), [keyn], ky, lerr) 2151 2128 2152 END FUNCTION fgetKey 2129 2153 … … 2142 2166 IF(lerr) RETURN 2143 2167 val = str2int(sval) 2144 lerr = val == -HUGE(1) .AND. sval /= ''2168 lerr = val == -HUGE(1) 2145 2169 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2146 2170 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2159 2183 IF(lerr) RETURN 2160 2184 val = str2real(sval) 2161 lerr = val == -HUGE(1.) .AND. sval /= ''2185 lerr = val == -HUGE(1.) 2162 2186 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2163 2187 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2177 2201 IF(lerr) RETURN 2178 2202 ival = str2bool(sval) 2179 lerr = ival == -1 .AND. sval /= ''2203 lerr = ival == -1 2180 2204 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2181 2205 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2212 2236 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2213 2237 val = str2int(svals) 2214 lerr = ANY(val == -HUGE(1)) .AND. sval /= ''2238 lerr = ANY(val == -HUGE(1)) 2215 2239 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2216 2240 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2232 2256 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2233 2257 val = str2real(svals) 2234 lerr = ANY(val == -HUGE(1.)) .AND. sval /= ''2258 lerr = ANY(val == -HUGE(1.)) 2235 2259 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2236 2260 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2253 2277 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2254 2278 ivals = str2bool(svals) 2255 lerr = ANY(ivals == -1) .AND. sval /= ''2279 lerr = ANY(ivals == -1) 2256 2280 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2257 2281 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2288 2312 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2289 2313 val = str2int(svals) 2290 lerr = ANY(val == -HUGE(1)) .AND. sval /= ''2314 lerr = ANY(val == -HUGE(1)) 2291 2315 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2292 2316 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2308 2332 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2309 2333 val = str2real(svals) 2310 lerr = ANY(val == -HUGE(1.)) .AND. sval /= ''2334 lerr = ANY(val == -HUGE(1.)) 2311 2335 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2312 2336 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2329 2353 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2330 2354 ivals = str2bool(svals) 2331 lerr = ANY(ivals == -1) .AND. sval /= ''2355 lerr = ANY(ivals == -1) 2332 2356 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2333 2357 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2388 2412 lerr = .TRUE. 2389 2413 IF(PRESENT(ky)) THEN; val = fgetKey(ky) !--- "ky" 2390 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:) )!--- "tracers"2414 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:)%keys) !--- "tracers" 2391 2415 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 2392 2416 END IF … … 2403 2427 TYPE(keys_type), INTENT(IN) :: ky(:) 2404 2428 LOGICAL, ALLOCATABLE :: ler(:) 2405 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname_all(:) 2406 lerr = SIZE(ky) == 0; IF(lerr) RETURN 2407 lerr = getKey('name', tname_all, ky); IF(lerr) RETURN 2429 lerr = SIZE(ky) == 0; IF(lerr) RETURN 2408 2430 ALLOCATE(ler(SIZE(tname))) 2409 val = [(fgetKeyIdx(strIdx( tname_all, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))]2431 val = [(fgetKeyIdx(strIdx(ky(:)%name, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))] 2410 2432 lerr = ANY(ler) 2411 2433 END FUNCTION fgetKey … … 2427 2449 IF(lerr) RETURN 2428 2450 val = str2int(svals) 2429 ll = val == -HUGE(1) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '')2451 ll = val == -HUGE(1) 2430 2452 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2431 2453 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2447 2469 IF(lerr) RETURN 2448 2470 val = str2real(svals) 2449 ll = val == -HUGE(1.) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '')2471 ll = val == -HUGE(1.) 2450 2472 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2451 2473 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2468 2490 IF(lerr) RETURN 2469 2491 ivals = str2bool(svals) 2470 ll = ivals == -1 .AND. (SIZE(svals) /=1 .OR. svals(1) /= '')2492 ll = ivals == -1 2471 2493 lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; RETURN; END IF 2472 2494 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2480 2502 !============================================================================================================================== 2481 2503 SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_) 2482 TYPE( keys_type), OPTIONAL, INTENT(IN) :: tracers_(:)2504 TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:) 2483 2505 TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:) 2484 2506 TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_ … … 2489 2511 IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF 2490 2512 IF(PRESENT(isotope_ )) THEN 2491 ix = strIdx(isotopes(:)% name, isotope_%name)2513 ix = strIdx(isotopes(:)%parent, isotope_%parent) 2492 2514 IF(ix /= 0) THEN 2493 2515 isotopes(ix) = isotope_ … … 2500 2522 !============================================================================================================================== 2501 2523 SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_) 2502 TYPE( keys_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:)2524 TYPE(trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:) 2503 2525 TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:) 2504 2526 TYPE(isot_type), OPTIONAL, INTENT(OUT) :: isotope_ … … 2507 2529 IF(PRESENT( tracers_)) THEN; tracers_ = tracers; ELSE; ALLOCATE( tracers_(0)); END IF 2508 2530 IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF 2509 IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)% name, isotope%name); IF(ix /= 0) isotope_=isotopes(ix); END IF2531 IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF 2510 2532 END SUBROUTINE getKeysDBase 2511 2533 !============================================================================================================================== … … 2583 2605 CHARACTER(LEN=*), INTENT(IN) :: tname 2584 2606 TYPE(keys_type), INTENT(IN) :: keys 2585 TYPE( keys_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:)2586 TYPE( keys_type), ALLOCATABLE :: tr(:)2607 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:) 2608 TYPE(trac_type), ALLOCATABLE :: tr(:) 2587 2609 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 2588 2610 INTEGER :: nt, ix 2589 2611 IF(ALLOCATED(tracs)) THEN 2590 lerr = getKey('name', tnames, ky=tracs(:) ); IF(lerr) RETURN2612 lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN 2591 2613 nt = SIZE(tracs) 2592 2614 ix = strIdx(tnames, tname) … … 2600 2622 ix = 1; ALLOCATE(tracs(1)) 2601 2623 END IF 2602 CALL addKey('name', tname, tracs(ix)) 2603 tracs(ix) = keys 2624 CALL addKey('name', tname, tracs(ix)%keys) 2625 tracs(ix)%name = tname 2626 tracs(ix)%keys = keys 2604 2627 2605 2628 END FUNCTION addTracer_1 … … 2616 2639 LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr) 2617 2640 CHARACTER(LEN=*), INTENT(IN) :: tname 2618 TYPE( keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:)2619 TYPE( keys_type), ALLOCATABLE :: tr(:)2641 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:) 2642 TYPE(trac_type), ALLOCATABLE :: tr(:) 2620 2643 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 2621 2644 INTEGER :: nt, ix … … 2623 2646 IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN 2624 2647 nt = SIZE(tracs) 2625 lerr = getKey('name', tnames, ky=tracs(:) ); IF(lerr) RETURN2648 lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN 2626 2649 ix = strIdx(tnames, tname) 2627 2650 CALL msg('Removing tracer "' //TRIM(tname)//'"', modname, ix /= 0) … … 2667 2690 2668 2691 !============================================================================================================================== 2669 !======== CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION & VICE VERSA ; OTHER NAMES ARE LEFT UNTOUCHED ========= 2670 !===== OLD NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") == 2671 !==== NEW NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var>='H2O' or from "newH2OIso") == 2692 !============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ================== 2693 !======= NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") ============ 2672 2694 !============================================================================================================================== 2673 2695 CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName) … … 2702 2724 END FUNCTION old2newH2O_m 2703 2725 !============================================================================================================================== 2726 2727 2728 !============================================================================================================================== 2729 !============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ================== 2730 !==== NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var> = 'H2O' or from "newH2OIso") ===== 2731 !============================================================================================================================== 2704 2732 CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName) 2705 2733 CHARACTER(LEN=*), INTENT(IN) :: newName -
LMDZ6/trunk/libf/phylmd/infotrac_phy.F90
r5184 r5190 3 3 MODULE infotrac_phy 4 4 5 USE strings_mod, ONLY: msg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strCount, strIdx 6 USE readTracFiles_mod, ONLY: readTracersFiles, maxTableWidth, tisot=>isot_type, addPhase, addKey, iH2O, & 7 indexUpdate, keys_type, testTracersFiles, processIsotopes, trac=>tracers, delPhase, getKey, tran0 8 USE readTracFiles_mod, ONLY: new2oldH2O 9 5 USE strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strIdx 6 USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, & 7 delPhase, niso, getKey, isot_type, processIsotopes, isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, & 8 addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate, iqWIsoPha, nbIso, ntiso, isoName, isoCheck 10 9 IMPLICIT NONE 11 10 … … 17 16 PUBLIC :: nqtot, nbtr, nqo, nqCO2, nqtottr !--- Main dimensions 18 17 PUBLIC :: conv_flg, pbl_flg !--- Convection & boundary layer activation keys 19 PUBLIC :: new2oldH2O !--- For backwards compatibility in phyetat0 20 PUBLIC :: addPhase, delPhase !--- Add/remove the phase from the name of a tracer 21 #if defined CPP_StratAer || defined REPROBUS 18 #ifdef CPP_StratAer 22 19 PUBLIC :: nbtr_bin, nbtr_sulgas !--- Number of aerosols bins and sulfur gases for StratAer model 23 20 PUBLIC :: id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat, id_TEST_strat 24 21 #endif 25 22 23 !=== FOR WATER 24 PUBLIC :: ivap, iliq, isol 26 25 !=== FOR ISOTOPES: General 27 26 PUBLIC :: isot_type, nbIso !--- Derived type, full isotopes families database + nb of families 28 PUBLIC :: isoSelect, ixIso , isoFamilies !--- Isotopes families selection tool + selected index + list27 PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index 29 28 !=== FOR ISOTOPES: Specific to water 30 PUBLIC :: iH2O !--- Value of "ixIso" for "H2O" isotopes class 31 PUBLIC :: ivap, iliq, isol 29 PUBLIC :: iH2O !--- H2O isotopes class index 32 30 !=== FOR ISOTOPES: Depending on the selected isotopes family 33 PUBLIC :: isotope !--- Selected isotopes database (argument of getKey) 34 PUBLIC :: isoKeys, isoName, isoZone, isoPhas !--- Isotopes keys & names, tagging zones names, phases 35 PUBLIC :: niso, ntiso, nzone, nphas !--- Number of " " 36 PUBLIC :: itZonIso !--- index "it" in "isoName(1:niso)" = f(tagging idx, isotope idx) 37 PUBLIC :: iqIsoPha !--- index "iq" in "qx" = f(isotope idx, phase idx) 38 PUBLIC :: iqWIsoPha !--- Same as iqIsoPha but with normal water phases 31 PUBLIC :: isotope, isoKeys !--- Selected isotopes database + associated keys (cf. getKey) 32 PUBLIC :: isoName, isoZone, isoPhas !--- Isotopes and tagging zones names, phases 33 PUBLIC :: niso, nzone, nphas, ntiso !--- " " numbers + isotopes & tagging tracers number 34 PUBLIC :: itZonIso !--- idx "it" (in "isoName(1:niso)") = function(tagging idx, isotope idx) 35 PUBLIC :: iqIsoPha !--- idx "iq" (in "qx") = function(isotope idx, phase idx) + aliases 36 PUBLIC :: iqWIsoPha !--- Same as iqIsoPha but with normal water phases 37 39 38 PUBLIC :: isoCheck !--- Run isotopes checking routines 40 39 !=== FOR BOTH TRACERS AND ISOTOPES … … 44 43 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 45 44 ! | water in different | water tagging | water isotopes | other tracers | additional tracers moments | 46 ! | phases: H2O_[gls rb]| isotopes | | | for higher order schemes |45 ! | phases: H2O_[gls] | isotopes | | | for higher order schemes | 47 46 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 48 47 ! | | | | | | … … 58 57 ! |-----------------------------------------------------------------------------------------------------------| 59 58 ! NOTES FOR THIS TABLE: 60 ! * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)% name== 'H2O'),59 ! * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)%parent == 'H2O'), 61 60 ! since water is so far the sole tracers family, except passive CO2, removed from the main tracers table. 62 61 ! * For water, "nqo" is equal to the more general field "isotopes(ip)%nphas". 63 62 ! * "niso", "nzone", "ntiso", "nphas" are defined for other isotopic tracers families, if any. 64 ! * If you deal with an isotopes family other than "H2O" ("Sulf" in the example), a good practice is to keep65 ! track of the isotopes class (of its index) before switching to it at the beginning of the dedicated code:66 ! - first time (use selection by name and compute the corresponding index iSulf) :67 ! i0=ixIso; IF(.NOT.isoSelect('Sulf')) CALL abort_physic("Can't select isotopes class", modname, 1); iS=ixIso68 ! - next times (use selection by index - "iS" has been computed at first call):69 ! i0=ixIso; IF(.NOT.isoSelect(iS)) CALL abort_physic("Can't select isotopes class", modname, 1)70 ! and to switch back to the original category when you're done with "Sulf":71 ! IF(.NOT.isoSelect(i0)) CALL abort_physic("Can't select isotopes class", modname, 1)72 ! to restore the original isotopes category (before dealing with "Sulf" (most of the time "H2O").73 63 ! 74 64 !=== DERIVED TYPE EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot) … … 78 68 ! |-------------+------------------------------------------------------+-------------+------------------------+ 79 69 ! | name | Name (short) | tname | | 80 ! | keys | key/val pairs accessible with "getKey" routine | / | |81 70 ! | gen0Name | Name of the 1st generation ancestor | / | | 82 71 ! | parent | Name of the parent | / | | 83 72 ! | longName | Long name (with adv. scheme suffix) for outputs | ttext | | 84 73 ! | type | Type (so far: tracer or tag) | / | tracer,tag | 85 ! | phase | Phases list ("g"as / "l"iquid / "s"olid | | [g|l|s|r|b] | 86 ! | | "r"(cloud) / "b"lowing) | / | | 74 ! | phase | Phases list ("g"as / "l"iquid / "s"olid) | / | [g][l][s] | 87 75 ! | component | Name(s) of the merged/cumulated section(s) | / | coma-separated names | 88 76 ! | iGeneration | Generation (>=1) | / | | … … 91 79 ! | nqDescen | Number of the descendants (all generations) | nqdesc | 1:nqtot | 92 80 ! | nqChildren | Number of childs (1st generation only) | nqfils | 1:nqtot | 93 ! | isAdvected | Advected tracers flag (.TRUE. if iadv >= 0) | / | nqtrue .TRUE. values | 94 ! | isInPhysics | Tracers not extracted from the main table in physics | / | nqtottr .TRUE. values | 81 ! | keys | key/val pairs accessible with "getKey" routine | / | | 82 ! | isAdvected | advected tracers flag (.TRUE. if iadv >= 0) | / | nqtrue .TRUE. values | 83 ! | isInPhysics | tracers not extracted from the main table in physics | / | nqtottr .TRUE. values | 95 84 ! | iso_iGroup | Isotopes group index in isotopes(:) | / | 1:nbIso | 96 85 ! | iso_iName | Isotope name index in isotopes(iso_iGroup)%trac(:) | iso_indnum | 1:niso | … … 104 93 ! | entry | length | Meaning | Former name | Possible values | 105 94 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 106 ! | name | Name of the isotopes class (family)| | |95 ! | parent | Parent tracer (isotopes family name) | | | 107 96 ! | keys | niso | Isotopes keys/values pairs list + number | | | 108 97 ! | trac | ntiso | Isotopes + tagging tracers list + number | / | ntraciso | | 109 98 ! | zone | nzone | Geographic tagging zones list + number | / | ntraceurs_zone | | 110 ! | phase | nphas | Phases list + number | | [g |l|s|r|b] 1:5|99 ! | phase | nphas | Phases list + number | | [g][l][s], 1:3 | 111 100 ! | iqIsoPha | Index in "qx" = f(name(1:ntiso)),phas) | iqiso | 1:nqtot | 112 ! | iqWIsoPha | Index in "qx" = f(name(1:ntiso+nqo)),phas) | ?| 1:nqtot |101 ! | iqWIsoPha | Index in "qx" = f(name(1:ntiso)),phas) | iqiso | 1:nqtot | 113 102 ! | itZonIso | Index in "trac(1:ntiso)"= f(zone, name(1:niso)) | index_trac | 1:ntiso | 114 103 ! +-----------------+--------------------------------------------------+--------------------+-----------------+ 115 104 116 !------------------------------------------------------------------------------------------------------------------------------117 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name"118 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer119 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector (general container)120 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name121 CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name122 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix)123 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag')124 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid)125 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca)126 INTEGER :: iGeneration = -1 !--- Generation number (>=0)127 INTEGER :: iqParent = 0 !--- Parent index128 INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order)129 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations)130 INTEGER :: nqChildren = 0 !--- Number of children (first generation)131 LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue132 LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr133 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:)134 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:)135 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:)136 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase137 END TYPE trac_type138 !------------------------------------------------------------------------------------------------------------------------------139 TYPE :: isot_type !=== TYPE FOR THE ISOTOPES FAMILY DESCENDING ON TRACER "name"140 CHARACTER(LEN=maxlen) :: name !--- Isotopes family name (ex: H2O)141 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso)142 LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering143 CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso)144 CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone)145 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g|l|s|r|b] (length: nphas)146 INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers147 INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers148 INTEGER :: nzone = 0 !--- Number of geographic tagging zones149 INTEGER :: nphas = 0 !--- Number of phases150 INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f( name(1:ntiso) ,phas)151 INTEGER, ALLOCATABLE :: iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f([H2O,name(1:ntiso)],phas)152 INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone,name(1:niso))153 END TYPE isot_type154 !------------------------------------------------------------------------------------------------------------------------------155 INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect156 !------------------------------------------------------------------------------------------------------------------------------157 158 !=== INDICES FOR WATER159 INTEGER, SAVE :: ivap, iliq, isol160 !$OMP THREADPRIVATE(ivap, iliq, isol)161 162 105 !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES 163 INTEGER, SAVE :: nqtot, &!--- Tracers nb in dynamics (incl. higher moments + H2O)164 nbtr, &!--- Tracers nb in physics (excl. higher moments + H2O)165 nqo, &!--- Number of water phases106 INTEGER, SAVE :: nqtot, & !--- Tracers nb in dynamics (incl. higher moments + H2O) 107 nbtr, & !--- Tracers nb in physics (excl. higher moments + H2O) 108 nqo, & !--- Number of water phases 166 109 nqtottr, & !--- Number of tracers passed to phytrac (TO BE DELETED ?) 167 110 nqCO2 !--- Number of tracers of CO2 (ThL) … … 169 112 !$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, type_trac) 170 113 171 !=== NUMBER AND LIST OF DEFINED ISOTOPES FAMILIES 172 INTEGER, SAVE :: nbIso !--- Number of defined isotopes classes 173 CHARACTER(LEN=maxlen), SAVE, ALLOCATABLE :: isoFamilies(:) !--- Generation 0 tracer name for each isotopes family (nbIso) 174 !$OMP THREADPRIVATE(isoFamilies) 175 176 !=== QUANTITIES RELATED TO THE CURRENTLY SELECTED ISOTOPES CLASS (USUALLY H2O) 177 TYPE(isot_type), SAVE, POINTER :: isotope !--- Selected isotopes database (=isotopes(ixIso)) 178 TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- Database to get isotopes keys using "getKey" (niso) 179 CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- Isotopes list including tagging tracers, no phase (ntiso) 180 isoZone(:), & !--- Geographic tagging zones list (nzone) 181 isoPhas !--- Used phases names ([g|l|s|r|b]) (nphas) 182 INTEGER, SAVE, POINTER :: itZonIso(:,:), & !--- Idx "it" in isoName(1:niso) = f(tagging idx, isotope idx) 183 iqIsoPha(:,:), & !--- Idx "iq" in qx = f(isotope idx, phase idx) 184 iqWIsoPha(:,:) !--- Idx "iq" in qx = f([parent trac,isotope idx], phase idx) 185 INTEGER, SAVE :: ixIso, & !--- Idx in "isoFamilies" of currently selectd class 186 niso, & !--- Number of isotopes 187 ntiso, & !--- Number of isotopes + tagging tracers 188 nzone, & !--- Number of tagging zones 189 nphas !--- Number of phases 190 LOGICAL, SAVE :: isoCheck !--- Isotopes checking routines triggering flag 191 !$OMP THREADPRIVATE(isotope, isoKeys, isoName, isoZone, isoPhas, itZonIso, iqIsoPha, iqWIsoPha, niso, ntiso, nzone, nphas, isoCheck) 114 !=== INDICES OF WATER 115 INTEGER, SAVE :: ivap,iliq,isol ! Indices for vap, liq and ice 116 !$OMP THREADPRIVATE(ivap,iliq,isol) 192 117 193 118 !=== VARIABLES FOR INCA 194 INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: &195 conv_flg, pbl_flg !--- Convection / boundary layer activation(nbtr)119 INTEGER, SAVE, ALLOCATABLE :: conv_flg(:), & !--- Convection activation ; needed for INCA (nbtr) 120 pbl_flg(:) !--- Boundary layer activation ; needed for INCA (nbtr) 196 121 !$OMP THREADPRIVATE(conv_flg, pbl_flg) 197 122 198 !=== TRACERS/ISOTOPES DESCRIPTORS: EFFECTIVE STORAGE (LOCAL DERIVED TYPES) 199 TYPE(trac_type), SAVE, ALLOCATABLE, TARGET :: tracers(:) 200 TYPE(isot_type), SAVE, ALLOCATABLE, TARGET :: isotopes(:) 201 !$OMP THREADPRIVATE(tracers, isotopes) 202 203 #if defined CPP_StratAer || defined REPROBUS 123 #ifdef CPP_StratAer 204 124 !=== SPECIFIC TO STRATOSPHERIC AEROSOLS (CK/OB) 205 125 INTEGER, SAVE :: nbtr_bin, nbtr_sulgas !--- number of aerosols bins and sulfur gases for StratAer model … … 213 133 SUBROUTINE init_infotrac_phy 214 134 USE ioipsl_getin_p_mod, ONLY: getin_p 215 USE mod_phys_lmdz_para, ONLY: is_master, is_omp_master216 135 #ifdef REPROBUS 217 136 USE CHEM_REP, ONLY: Init_chem_rep_trac … … 242 161 !------------------------------------------------------------------------------------------------------------------------------ 243 162 ! Local variables 244 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) , itmp(:)!--- Horizontal/vertical transport scheme number163 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) !--- Horizontal/vertical transport scheme number 245 164 #ifdef INCA 246 165 INTEGER, ALLOCATABLE :: had (:), hadv_inca(:), conv_flg_inca(:), &!--- Variables specific to INCA … … 254 173 CHARACTER(LEN=2) :: suff(9) !--- Suffixes for schemes of order 3 or 4 (Prather) 255 174 CHARACTER(LEN=3) :: descrq(30) !--- Advection scheme description tags 256 CHARACTER(LEN=maxlen) :: msg1, texp, ttp , ky !--- Stringsfor messages and expanded tracers type175 CHARACTER(LEN=maxlen) :: msg1, texp, ttp !--- String for messages and expanded tracers type 257 176 INTEGER :: fType !--- Tracers description file type ; 0: none 258 177 !--- 1/2/3: "traceur.def"/"tracer.def"/"tracer_*.def" 259 178 INTEGER :: nqtrue !--- Tracers nb from tracer.def (no higher order moments) 260 179 INTEGER :: iad !--- Advection scheme number 261 INTEGER :: iq, jq, it, nt, im, nm !--- Indexes and temporary variables 262 LOGICAL :: lInit 263 TYPE(keys_type), ALLOCATABLE, TARGET :: tra(:) !--- Tracers descriptor as in readTracFiles_mod 264 TYPE(tisot), ALLOCATABLE :: iso(:) !--- Isotopes descriptor as in readTracFiles_mod 180 INTEGER :: iq, jq, nt, im, nm, k !--- Indexes and temporary variables 181 LOGICAL :: lerr, lInit 265 182 TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:) 266 TYPE(trac_type), POINTER :: t (:), t1267 TYPE(keys_type), POINTER :: k(:)268 CHARACTER(LEN=maxlen), ALLOCATABLE :: types_trac(:) !--- Keywords for tracers type(s), parsed version183 TYPE(trac_type), POINTER :: t1, t(:) 184 CHARACTER(LEN=maxlen), ALLOCATABLE :: types_trac(:) !--- Keyword for tracers type(s), parsed version 185 269 186 CHARACTER(LEN=*), PARAMETER :: modname="init_infotrac_phy" 270 187 !------------------------------------------------------------------------------------------------------------------------------ … … 278 195 279 196 CALL getin_p('type_trac',type_trac) 280 CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname, is_master) 281 IF(strCount(type_trac, '|', nt)) CALL abort_physic(modname, 'Could''nt parse the "type_trac" string with delimiter "|"', 1) 282 IF(nt >= 3) CALL abort_physic(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1) 283 IF(strParse(type_trac, '|', types_trac, n=nt)) CALL abort_physic(modname, "couldn't parse "//'"type_trac"', 1) 284 IF(nt == 2) type_trac = types_trac(2) ! TO BE DELETED SOON 285 286 lInit = .NOT.ALLOCATED(trac) 287 288 !############################################################################################################################## 289 IF(lInit .AND. is_master) THEN !=== SKIPED IF ALREADY DONE 197 198 lerr=strParse(type_trac, '|', types_trac, n=nt) 199 IF (nt .GT. 1) THEN 200 IF (nt .GT. 2) CALL abort_physic(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1) 201 IF (nt .EQ. 2) type_trac=types_trac(2) 202 ENDIF 203 204 205 CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname) 206 lInit = .NOT.ALLOCATED(tracers) 207 208 !############################################################################################################################## 209 IF(lInit) THEN !=== SKIPED IF ALREADY DONE IN dyn3d_common/infotrac #### 290 210 !############################################################################################################################## 291 211 !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION … … 320 240 !############################################################################################################################## 321 241 322 !============================================================================================================================== 323 ! 0) DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE AND READ IT ; TRANSFER THE NEEDED QUANTITIES TO LOCAL "tracers". 324 !============================================================================================================================== 325 texp = type_trac !=== EXPANDED (WITH "|" SEPARATOR) "type_trac" 242 nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] ) 243 244 !============================================================================================================================== 245 ! 1) Get the numbers of: true (first order only) tracers "nqtrue", water tracers "nqo" (vapor/liquid/solid) 246 !============================================================================================================================== 247 texp = type_trac !=== EXPANDED VERSION OF "type_trac", WITH "|" SEPARATOR 326 248 IF(texp == 'inco') texp = 'co2i|inca' 327 249 IF(texp /= 'lmdz') texp = 'lmdz|'//TRIM(texp) 328 IF(testTracersFiles(modname, texp, fType, lInit.AND.is_master)) CALL abort_physic(modname, 'problem with tracers file(s)',1) 250 251 !=== DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE 252 IF(testTracersFiles(modname, texp, fType, lInit)) CALL abort_physic(modname, 'problem with tracers file(s)',1) 253 329 254 ttp = type_trac; IF(fType /= 1) ttp = texp 330 !--------------------------------------------------------------------------------------------------------------------------- 331 IF(fType == 0) CALL abort_physic(modname, 'Missing "traceur.def", "tracer.def" or "tracer_<keyword>.def tracers file.',1) 332 !--------------------------------------------------------------------------------------------------------------------------- 333 IF(fType == 1 .AND. ANY(['inca', 'inco'] == type_trac)) & !=== FOUND OLD STYLE INCA "traceur.def" 334 CALL abort_physic(modname, 'retro-compatibility with old-style INCA traceur.def files has been disabled.', 1) 335 !--------------------------------------------------------------------------------------------------------------------------- 336 337 !############################################################################################################################## 338 IF(lInit .AND. is_omp_master) THEN 339 IF(readTracersFiles(ttp, tra, type_trac == 'repr')) CALL abort_physic(modname, 'problem with tracers file(s)',1) 255 256 !############################################################################################################################## 257 IF(lInit) THEN 258 IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_physic(modname, 'problem with tracers file(s)',1) 340 259 ELSE 341 tra = trac 342 END IF 343 CALL msg('No tracers description file(s) reading needed: already done', modname, .NOT.lInit.AND.is_master) 344 !############################################################################################################################## 345 346 !--- POPULATE SOME EXPLICIT (ACCESSIBLE THROUGH "%") KEYS OF THE LOCAL TRACERS DESCRIPTION DERIVED TYPE 347 ! To be defined: iqParent, iq/nqDescen, nqChildren (in indexUpdate), longName, iso_i*, isAdvected, isInPhysics (later) 348 ALLOCATE(tracers(SIZE(tra))) 349 DO iq = 1, SIZE(tra); t1 => tracers(iq) 350 t1%keys = tra(iq) 351 msg1 = '" for tracer nr. '//TRIM(int2str(iq)) 352 ky='name '; IF(getKey(ky, t1%name, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 353 msg1 = '" for "'//TRIM(t1%name)//'"' 354 ky='gen0Name '; IF(getKey(ky, t1%gen0Name, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 355 ky='parent '; IF(getKey(ky, t1%parent, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 356 ky='type '; IF(getKey(ky, t1%type, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 357 ky='phase '; IF(getKey(ky, t1%phase, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 358 ky='component '; IF(getKey(ky, t1%component, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 359 ky='iGeneration'; IF(getKey(ky, t1%iGeneration, iq, tra)) CALL abort_physic(modname, 'No key "'//TRIM(ky)//TRIM(msg1), 1) 360 END DO 361 362 !============================================================================================================================== 363 ! 1) Get various numbers: "nqtrue" (first order only tracers), "nqo" (water phases), 'nbtr' (tracers passed to physics), etc. 364 !============================================================================================================================== 365 nqtrue = SIZE(tracers) !--- "true" tracers 366 nqo = COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%name) == 'H2O') !--- Water phases 367 nbtr = nqtrue-COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%gen0Name) == 'H2O') !--- Passed to phytrac 368 nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] ) 260 CALL msg('No tracers description file(s) reading needed: already done in the dynamics', modname) 261 END IF 262 !############################################################################################################################## 263 264 !--------------------------------------------------------------------------------------------------------------------------- 265 IF(fType == 0) CALL abort_physic(modname, 'Missing tracers file: "traceur.def", "tracer.def" or "tracer_<keyword>.def file.',1) 266 !--------------------------------------------------------------------------------------------------------------------------- 267 IF(fType == 1 .AND. ANY(['inca','inco']==type_trac) .AND. lInit) THEN !=== FOUND OLD STYLE INCA "traceur.def" 268 !--------------------------------------------------------------------------------------------------------------------------- 369 269 #ifdef INCA 370 nqINCA = COUNT(tracers(:)%component == 'inca') 371 #endif 270 nqo = SIZE(tracers) - nqCO2 271 CALL Init_chem_inca_trac(nqINCA) !--- Get nqINCA from INCA 272 nbtr = nqINCA + nqCO2 !--- Number of tracers passed to phytrac 273 nqtrue = nbtr + nqo !--- Total number of "true" tracers 274 IF(ALL([2,3] /= nqo)) CALL abort_physic(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1) 275 ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA)) 276 ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA), pbl_flg_inca(nqINCA)) 277 CALL init_transport(solsym_inca, conv_flg_inca, pbl_flg_inca, hadv_inca, vadv_inca) 278 ALLOCATE(ttr(nqtrue)) 279 ttr(1:nqo+nqCO2) = tracers 280 ttr(1 : nqo )%component = 'lmdz' 281 ttr(1+nqo:nqCO2+nqo )%component = 'co2i' 282 ttr(1+nqo+nqCO2:nqtrue)%component = 'inca' 283 ttr(1+nqo :nqtrue)%name = [('CO2 ', k=1, nqCO2), solsym_inca] 284 ttr(1+nqo+nqCO2:nqtrue)%parent = tran0 285 ttr(1+nqo+nqCO2:nqtrue)%phase = 'g' 286 lerr = getKey('hadv', had, ky=tracers(:)%keys) 287 lerr = getKey('vadv', vad, ky=tracers(:)%keys) 288 hadv(1:nqo+nqCO2) = had(:); hadv(1+nqo+nqCO2:nqtrue) = hadv_inca 289 vadv(1:nqo+nqCO2) = vad(:); vadv(1+nqo+nqCO2:nqtrue) = vadv_inca 290 CALL MOVE_ALLOC(FROM=ttr, TO=tracers) 291 DO iq = 1, nqtrue 292 t1 => tracers(iq) 293 CALL addKey('name', t1%name, t1%keys) 294 CALL addKey('component', t1%component, t1%keys) 295 CALL addKey('parent', t1%parent, t1%keys) 296 CALL addKey('phase', t1%phase, t1%keys) 297 END DO 298 IF(setGeneration(tracers)) CALL abort_physic(modname,'See below',1) !- SET FIELDS %iGeneration, %gen0Name 299 DEALLOCATE(had, hadv_inca, vad, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca) 300 #endif 301 !--------------------------------------------------------------------------------------------------------------------------- 302 ELSE !=== OTHER CASES (OLD OR NEW FORMAT, NO INCA MODULE) 303 !--------------------------------------------------------------------------------------------------------------------------- 304 nqo = COUNT(delPhase(tracers(:)%name) == 'H2O' & 305 .AND. tracers(:)%component == 'lmdz') !--- Number of water phases 306 nqtrue = SIZE(tracers) !--- Total number of "true" tracers 307 nbtr = nqtrue-COUNT(delPhase(tracers(:)%gen0Name) == 'H2O' & 308 .AND. tracers(:)%component == 'lmdz') !--- Number of tracers passed to phytrac 309 #ifdef INCA 310 nqINCA = COUNT(tracers(:)%component == 'inca') 311 #endif 312 lerr = getKey('hadv', hadv, ky=tracers(:)%keys) 313 lerr = getKey('vadv', vadv, ky=tracers(:)%keys) 314 !--------------------------------------------------------------------------------------------------------------------------- 315 END IF 316 !--------------------------------------------------------------------------------------------------------------------------- 317 318 !--- Transfert the number of tracers to Reprobus 372 319 #ifdef REPROBUS 373 CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name) !--- Transfert the number of tracers to Reprobus 374 #endif 320 CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name) 321 #endif 322 323 !############################################################################################################################## 324 IF(lInit) THEN !=== SKIPED IF ALREADY DONE IN dyn3d_common/infotrac #### 325 !############################################################################################################################## 375 326 376 327 !============================================================================================================================== 377 328 ! 2) Calculate nqtot, number of tracers needed (greater if advection schemes 20 or 30 have been chosen). 378 329 !============================================================================================================================== 379 IF(getKey('hadv', hadv, ky=tra)) CALL abort_physic(modname, 'missing key "hadv"', 1)380 IF(getKey('vadv', vadv, ky=tra)) CALL abort_physic(modname, 'missing key "vadv"', 1)381 330 DO iq = 1, nqtrue 382 331 IF( hadv(iq)<20 .OR. (ANY(hadv(iq)==[20,30]) .AND. hadv(iq)==vadv(iq)) ) CYCLE … … 399 348 !============================================================================================================================== 400 349 ALLOCATE(ttr(nqtot)) 401 jq = nqtrue+1 350 jq = nqtrue+1; tracers(:)%iadv = -1 402 351 DO iq = 1, nqtrue 403 352 t1 => tracers(iq) … … 410 359 IF(iad == -1) CALL abort_physic(modname, msg1, 1) 411 360 412 !--- SET FIELDS longName, isAdvected,isInPhysics361 !--- SET FIELDS %longName, %isAdvected, %isInPhysics 413 362 t1%longName = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad) 414 363 t1%isAdvected = iad >= 0 415 t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' .OR. t1%component /= 'lmdz' !=== MORE EXCEPTIONS ? CO2i, SURSAT CLOUD H2O 364 t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' & 365 .OR. t1%component /= 'lmdz' !=== OTHER EXCEPTIONS TO BE ADDED: CO2i, SURSATURATED WATER CLOUD... 416 366 ttr(iq) = t1 417 367 … … 422 372 IF(nm == 0) CYCLE !--- No higher moments 423 373 ttr(jq+1:jq+nm) = t1 424 ttr(jq+1:jq+nm)%name = [ (TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ] 425 ttr(jq+1:jq+nm)%gen0Name = [ (TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ] 426 ttr(jq+1:jq+nm)%parent = [ (TRIM(t1%parent) //'-'//TRIM(suff(im)), im=1, nm) ] 427 ttr(jq+1:jq+nm)%longName = [ (TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ] 428 ttr(jq+1:jq+nm)%isAdvected = [ (.FALSE., im=1, nm) ] 429 ttr(jq+1:jq+nm)%isInPhysics = [ (.FALSE., im=1, nm) ] 374 ttr(jq+1:jq+nm)%name = [(TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ] 375 ttr(jq+1:jq+nm)%parent = [(TRIM(t1%parent) //'-'//TRIM(suff(im)), im=1, nm) ] 376 ttr(jq+1:jq+nm)%longName = [(TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ] 377 ttr(jq+1:jq+nm)%isAdvected = [(.FALSE., im=1, nm) ] 430 378 jq = jq + nm 431 379 END DO … … 433 381 CALL MOVE_ALLOC(FROM=ttr, TO=tracers) 434 382 435 !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren 436 IF(indexUpdate(tracers%keys)) CALL abort_physic(modname, 'problem with tracers indices update', 1) 437 k => tracers(:)%keys 438 DO iq = 1, SIZE(tracers); t1 => tracers(iq); msg1 = '" for "'//TRIM(t1%name)//'"' 439 ky='iqParent '; IF(getKey(ky, t1%iqParent, iq, k)) CALL abort_physic(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 440 ky='iqDescen '; IF(getKey(ky, t1%iqDescen, iq, k)) CALL abort_physic(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 441 ky='nqDescen '; IF(getKey(ky, t1%nqDescen, iq, k)) CALL abort_physic(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 442 ky='nqChildren'; IF(getKey(ky, t1%nqChildren, iq, k)) CALL abort_physic(modname, 'missing key "'//TRIM(ky)//TRIM(msg1), 1) 443 END DO 444 445 !=== DETERMINE ISOTOPES RELATED PARAMETERS ; DEFINE THE EXPLICIT KEYS iso_i* 446 IF(processIsotopes(tracers%keys, iso)) CALL abort_physic(modname, 'problem while processing isotopes parameters', 1) 447 448 !--- POPULATE SOME EXPLICIT (ACCESSIBLE THROUGH "%") KEYS OF THE LOCAL ISOTOPES DESCRIPTION DERIVED TYPE 449 nbIso = SIZE(iso) 450 ALLOCATE(isotopes(nbIso)) 451 IF(nbIso /= 0) THEN 452 k => tracers(:)%keys 453 IF(getKey('iso_iGroup', itmp, ky=k)) CALL abort_physic(modname, 'missing key "iso_iGroup"', 1); tracers%iso_iGroup = itmp 454 IF(getKey('iso_iName', itmp, ky=k)) CALL abort_physic(modname, 'missing key "iso_iName"', 1); tracers%iso_iName = itmp 455 IF(getKey('iso_iZone', itmp, ky=k)) CALL abort_physic(modname, 'missing key "iso_iZone"', 1); tracers%iso_iZone = itmp 456 IF(getKey('iso_iPhas', itmp, ky=k)) CALL abort_physic(modname, 'missing key "iso_iPhas"', 1); tracers%iso_iPhase = itmp 457 isotopes(:)%name = iso(:)%name !--- Isotopes family name (ex: H2O) 458 isotopes(:)%phase = iso(:)%phase !--- Phases list: [g][l][s] (length: nphas) 459 isotopes(:)%niso = iso(:)%niso !--- Number of isotopes, excluding tagging tracers 460 isotopes(:)%ntiso = iso(:)%ntiso !--- Number of isotopes, including tagging tracers 461 isotopes(:)%nzone = iso(:)%nzone !--- Number of geographic tagging zones 462 isotopes(:)%nphas = iso(:)%nphas !--- Number of phases 463 isotopes(:)%check = .FALSE. !--- Flag for checking routines triggering 464 CALL getin_p('ok_iso_verif', isotopes(:)%check) 465 DO it = 1, nbIso 466 isotopes(it)%keys = iso(it)%keys !--- Isotopes keys/values pairs list (length: niso) 467 isotopes(it)%trac = iso(it)%trac !--- Isotopes + tagging tracers list (length: ntiso) 468 isotopes(it)%zone = iso(it)%zone !--- Geographic tagging zones names list (length: nzone) 469 isotopes(it)%iqIsoPha = iso(it)%iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 470 isotopes(it)%iqWIsoPha= iso(it)%iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f([trPrnt,name(1:ntiso)],phas) 471 isotopes(it)%itZonIso = iso(it)%itZonIso(:,:) !--- Idx in "tracers(1:ntiso)" = f( zone,name(1:niso)) 472 END DO 473 IF(isoSelect(1, .TRUE.)) CALL abort_physic(modname, "Can't select the first isotopes family", 1) 474 IF(.NOT.isoSelect('H2O', .TRUE.)) iH2O = ixIso 475 END IF 476 isoFamilies = isotopes(:)%name 477 383 !--- SET FIELDS %iqParent, %nqChildren, %iGeneration, %iqDescen, %nqDescen 384 IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1) 385 386 !############################################################################################################################## 387 END IF 388 !############################################################################################################################## 389 390 !############################################################################################################################## 391 IF(.NOT.lInit) THEN 392 !############################################################################################################################## 393 nqtot = SIZE(tracers) 394 !############################################################################################################################## 395 ELSE 396 !############################################################################################################################## 397 398 !=== READ PHYSICAL PARAMETERS FOR ISOTOPES 399 niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE. 400 IF(processIsotopes()) CALL abort_physic(modname, 'Problem when processing isotopes parameters', 1) 401 402 !############################################################################################################################## 403 END IF 404 !############################################################################################################################## 478 405 !--- Convection / boundary layer activation for all tracers 479 IF (.NOT.ALLOCATED(conv_flg)) ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1480 IF (.NOT.ALLOCATED(pbl_flg)) ALLOCATE( pbl_flg(nbtr)); pbl_flg(1:nbtr) = 1406 IF (.NOT.ALLOCATED(conv_flg)) ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1 407 IF (.NOT.ALLOCATED(pbl_flg)) ALLOCATE( pbl_flg(nbtr)); pbl_flg(1:nbtr) = 1 481 408 482 409 !--- Note: nqtottr can differ from nbtr when nmom/=0 … … 486 413 487 414 !=== DISPLAY THE RESULTS 488 IF(.NOT.is_master) RETURN489 415 CALL msg('nqo = '//TRIM(int2str(nqo)), modname) 490 416 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) … … 498 424 #endif 499 425 t => tracers 500 CALL msg('Information stored in '//TRIM(modname)//': ', modname) 501 IF(dispTable('isssssssssiiiiiiii', ['iq ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp', & 502 'isPh', 'isAd', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'], & 503 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, & 504 bool2str(t%isInPhysics), bool2str(t%isAdvected)), & 426 CALL msg('Information stored in infotrac_phy :', modname) 427 IF(dispTable('issssssssiiiiiiii', ['iq ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp', & 428 'isPh', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'], & 429 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isInPhysics)),& 505 430 cat([(iq, iq=1, nqtot)], t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup, & 506 431 t%iso_iName, t%iso_iZone, t%iso_iPhase), nColMax=maxTableWidth, nHead=2, sub=modname)) & 507 432 CALL abort_physic(modname, "problem with the tracers table content", 1) 433 IF(niso > 0) THEN 434 CALL msg('Where, for isotopes family "'//TRIM(isotope%parent)//'":', modname) 435 CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) 436 CALL msg(' isoName = '//strStack(isoName), modname) 437 CALL msg(' isoZone = '//strStack(isoZone), modname) 438 CALL msg(' isoPhas = '//TRIM(isoPhas), modname) 439 ELSE 440 CALL msg('No isotopes identified.', modname) 441 END IF 442 443 #ifdef ISOVERIF 444 CALL msg('iso_iName = '//strStack(int2str(PACK(tracers(:)%iso_iName, MASK=tracers(:)%iso_iGroup==iH2O))), modname) 445 #endif 508 446 #ifdef CPP_StratAer 509 447 IF (type_trac == 'coag') THEN … … 525 463 END IF 526 464 #endif 527 CALL msg('No isotopes identified.', modname, nbIso == 0) 528 IF(nbIso == 0) RETURN 529 DO it = 1, nbIso 530 IF(isoSelect(it, .TRUE.)) CALL abort_physic(modname, 'Problem when selecting isotopes class', 1) 531 CALL msg('For isotopes family "'//TRIM(isoFamilies(it))//'":', modname) 532 CALL msg(' isoName = '//strStack(isotope%trac), modname) 533 CALL msg(' isoZone = '//strStack(isotope%zone), modname) 534 CALL msg(' isoPhas = '// TRIM(isotope%phase), modname) 535 END DO 536 IF(isoSelect('H2O', .TRUE.)) THEN 537 IF(isoSelect(1, .TRUE.)) CALL abort_physic(modname, 'Problem when selecting isotopes class', 1) 538 ELSE 539 iH2O = ixIso 540 END IF 541 IF(ALLOCATED(isotope%keys(ixIso)%key)) & 542 CALL msg(' isoKeys('//TRIM(int2str(ixIso))//') = '//TRIM(strStack(isotope%keys(ixIso)%key)), modname) 543 #ifdef ISOVERIF 544 CALL msg('iso_iName(H2O) = '//TRIM(strStack(int2str(PACK(tracers%iso_iName, MASK=tracers%iso_iGroup==iH2O)))),modname) 545 #endif 465 CALL msg('end', modname) 546 466 547 467 END SUBROUTINE init_infotrac_phy 548 468 549 !==============================================================================================================================550 LOGICAL FUNCTION isoSelectByName(iClass, lVerbose) RESULT(lerr)551 IMPLICIT NONE552 CHARACTER(LEN=*), INTENT(IN) :: iClass553 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose554 INTEGER :: iIso555 LOGICAL :: lV556 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose557 iIso = strIdx(isotopes(:)%name, iClass)558 lerr = iIso == 0559 IF(lerr) THEN560 niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.561 CALL msg('no isotope family named "'//TRIM(iClass)//'"', ll=lV)562 RETURN563 END IF564 lerr = isoSelectByIndex(iIso, lV)565 END FUNCTION isoSelectByName566 !==============================================================================================================================567 LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)568 IMPLICIT NONE569 INTEGER, INTENT(IN) :: iIso570 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose571 LOGICAL :: lV572 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose573 lerr = .FALSE.574 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK575 lerr = iIso<=0 .OR. iIso>SIZE(isotopes)576 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '&577 //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV)578 IF(lerr) RETURN579 ixIso = iIso !--- Update currently selected family index580 isotope => isotopes(ixIso) !--- Select corresponding component581 isoKeys => isotope%keys; niso = isotope%niso582 isoName => isotope%trac; ntiso = isotope%ntiso583 isoZone => isotope%zone; nzone = isotope%nzone584 isoPhas => isotope%phase; nphas = isotope%nphas585 itZonIso => isotope%itZonIso; isoCheck = isotope%check586 iqIsoPha => isotope%iqIsoPha587 iqWIsoPha=> isotope%iqWIsoPha588 END FUNCTION isoSelectByIndex589 !==============================================================================================================================590 591 469 END MODULE infotrac_phy -
LMDZ6/trunk/libf/phylmd/phyetat0_mod.F90
r5183 r5190 32 32 USE geometry_mod, ONLY: longitude_deg, latitude_deg 33 33 USE iostart, ONLY: close_startphy, get_field, get_var, open_startphy 34 USE infotrac_phy, ONLY: nqtot, nbtr, type_trac, tracers , new2oldH2O35 USE strings_mod, ONLY: maxlen34 USE infotrac_phy, ONLY: nqtot, nbtr, type_trac, tracers 35 USE readTracFiles_mod,ONLY: maxlen, new2oldH2O 36 36 USE traclmdz_mod, ONLY: traclmdz_from_restart 37 37 USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo -
LMDZ6/trunk/libf/phylmd/physiq_mod.F90
r5189 r5190 39 39 USE ioipsl_getin_p_mod, ONLY : getin_p 40 40 USE indice_sol_mod 41 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac, addPhase 41 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac 42 USE readTracFiles_mod, ONLY: addPhase 42 43 USE strings_mod, ONLY: strIdx 43 44 USE iophy -
LMDZ6/trunk/libf/phylmdiso/isotopes_mod.F90
r5183 r5190 4 4 MODULE isotopes_mod 5 5 USE strings_mod, ONLY: msg, real2str, int2str, bool2str, maxlen, strIdx, strStack 6 USE infotrac_phy, ONLY: isoName, isoSelect, niso, ntiso, nbIso, isoFamilies 7 USE iso_params_mod 6 USE infotrac_phy, ONLY: isoName 8 7 IMPLICIT NONE 9 8 INTERFACE get_in; MODULE PROCEDURE getinp_s, getinp_i, getinp_r, getinp_l; END INTERFACE get_in … … 12 11 !--- Contains all isotopic variables + their initialization 13 12 !--- Isotopes-specific routines are in isotopes_routines_mod to avoid circular dependencies with isotopes_verif_mod. 14 15 !--- Negligible lower thresholds: no need to check for absurd values under these lower limits16 REAL, PARAMETER :: &17 ridicule = 1e-12, & ! For mixing ratios18 ridicule_rain = 1e-8, & ! For rain fluxes (rain, zrfl...) in kg/s <-> 1e-3 mm/day19 ridicule_evap = ridicule_rain*1e-2, & ! For evaporations in kg/s <-> 1e-3 mm/day20 ridicule_qsol = ridicule_rain, & ! For qsol in kg <-> 1e-8 kg21 ridicule_snow = ridicule_qsol ! For snow in kg <-> 1e-8 kg22 REAL, PARAMETER :: expb_max = 30.023 24 !--- Fractionation coefficients for H217O25 REAL, PARAMETER :: fac_coeff_eq17_liq = 0.529, &26 fac_coeff_eq17_ice = 0.52927 28 !--- H218O reference29 REAL, PARAMETER :: fac_enrichoce18 = 0.0005, alpha_liq_sol_O18 = 1.00291, &30 talph1_O18 = 1137., talps1_O18 = 11.839, tkcin0_O18 = 0.006, &31 talph2_O18 = -0.4156, talps2_O18 = -0.028244, tkcin1_O18 = 0.000285, &32 talph3_O18 = -2.0667E-3, tdifrel_O18 = 1./0.9723, tkcin2_O18 = 0.0008233 34 !--- Parameters that do not depend on the nature of water isotopes:35 REAL, PARAMETER :: pxtmelt = 273.15 !--- temperature at which ice formation starts36 REAL, PARAMETER :: pxtice = 273.15 - 10.0 !--- temperature at which all condensate is ice:37 REAL, PARAMETER :: pxtmin = 273.15 - 120.0 !--- computation done only under -120°C38 REAL, PARAMETER :: pxtmax = 273.15 + 60.0 !--- computation done only over +60°C39 REAL, PARAMETER :: tdifexp = 0.58 !--- a constant for alpha_eff for equilibrium below cloud base:40 REAL, PARAMETER :: tv0cin = 7.0 !--- wind threshold (m/s) for smooth/rough regime (Merlivat and Jouzel 1979)41 REAL, PARAMETER :: musi = 1.0 !--- facteurs lambda et mu dans Si=musi-lambda*T42 REAL, PARAMETER :: Kd = 2.5e-9 ! m2/s !--- diffusion in soil43 REAL, PARAMETER :: rh_cste_surf_cond = 0.6 !--- cste_surf_cond case: rhs and/or Ts set to constants44 REAL, PARAMETER :: T_cste_surf_cond = 288.045 13 46 14 !--- Isotopes indices (in [1,niso] ; non-existing => 0 index) … … 121 89 !--- Vectors of length "niso" 122 90 REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & 123 alpha,tnat, toce, tcorr, tdifrel124 !$OMP THREADPRIVATE( alpha,tnat, toce, tcorr, tdifrel)91 tnat, toce, tcorr, tdifrel 92 !$OMP THREADPRIVATE(tnat, toce, tcorr, tdifrel) 125 93 REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & 126 94 talph1, talph2, talph3, talps1, talps2 … … 132 100 alpha_liq_sol, Rdefault, Rmethox 133 101 !$OMP THREADPRIVATE(alpha_liq_sol, Rdefault, Rmethox) 102 ! REAL, SAVE :: fac_coeff_eq17_liq, fac_coeff_eq17_ice 103 !!$OMP THREADPRIVATE(fac_coeff_eq17_liq, fac_coeff_eq17_ice) 104 105 !--- H2[18]O reference 106 REAL, PARAMETER :: fac_enrichoce18=0.0005 107 REAL, PARAMETER :: alpha_liq_sol_O18=1.00291 108 REAL, PARAMETER :: talph1_O18=1137. 109 REAL, PARAMETER :: talph2_O18=-0.4156 110 REAL, PARAMETER :: talph3_O18=-2.0667E-3 111 REAL, PARAMETER :: talps1_O18=11.839 112 REAL, PARAMETER :: talps2_O18=-0.028244 113 REAL, PARAMETER :: tdifrel_O18=1./0.9723 114 REAL, PARAMETER :: tkcin0_O18=0.006 115 REAL, PARAMETER :: tkcin1_O18=0.000285 116 REAL, PARAMETER :: tkcin2_O18=0.00082 117 REAL, PARAMETER :: fac_coeff_eq17_liq=0.529 118 REAL, PARAMETER :: fac_coeff_eq17_ice=0.529 119 120 !---- Parameters that do not depend on the nature of water isotopes: 121 REAL, PARAMETER :: pxtmelt = 273.15 ! temperature at which ice formation starts 122 REAL, PARAMETER :: pxtice = 273.15-10.0 ! -- temperature at which all condensate is ice: 123 REAL, PARAMETER :: pxtmin = 273.15 - 120.0 ! On ne calcule qu'au dessus de -120°C 124 REAL, PARAMETER :: pxtmax = 273.15 + 60.0 ! On ne calcule qu'au dessus de +60°C 125 REAL, PARAMETER :: tdifexp = 0.58 ! -- a constant for alpha_eff for equilibrium below cloud base: 126 REAL, PARAMETER :: tv0cin = 7.0 ! wind threshold (m/s) for smooth/rough regime (Merlivat and Jouzel 1979) 127 REAL, PARAMETER :: musi=1.0 ! facteurs lambda et mu dans Si=musi-lambda*T 128 REAL, PARAMETER :: Kd=2.5e-9 ! m2/s ! diffusion dans le sol 129 REAL, PARAMETER :: rh_cste_surf_cond = 0.6 ! cas où cste_surf_cond: on met rhs ou/et Ts cste pour voir 130 REAL, PARAMETER :: T_cste_surf_cond = 288.0 131 132 133 !--- Negligible lower thresholds: no need to check for absurd values under these lower limits 134 REAL, PARAMETER :: & 135 ridicule = 1e-12, & ! For mixing ratios 136 ridicule_rain = 1e-8, & ! For rain fluxes (rain, zrfl...) in kg/s <-> 1e-3 mm/day 137 ridicule_evap = ridicule_rain*1e-2, & ! For evaporations in kg/s <-> 1e-3 mm/day 138 ridicule_qsol = ridicule_rain, & ! For qsol in kg <-> 1e-8 kg 139 ridicule_snow = ridicule_qsol ! For snow in kg <-> 1e-8 kg 140 REAL, PARAMETER :: expb_max = 30.0 134 141 135 142 !--- Specific to HTO: … … 148 155 149 156 SUBROUTINE iso_init() 157 USE infotrac_phy, ONLY: ntiso, niso, getKey 158 USE strings_mod, ONLY: maxlen 150 159 IMPLICIT NONE 151 160 152 161 !=== Local variables: 153 INTEGER :: ixt, ii, is 154 LOGICAL :: ltnat1 155 CHARACTER(LEN=maxlen) :: modname, sxt 162 INTEGER :: ixt 163 156 164 157 165 !--- For H2[17]O … … 162 170 LOGICAL, PARAMETER :: ok_nocinsat = .FALSE. ! if T: no sursaturation effect for ice 163 171 LOGICAL, PARAMETER :: Rdefault_smow = .FALSE. ! if T: Rdefault=smow; if F: nul 172 LOGICAL, PARAMETER :: tnat1 = .TRUE. ! If T: all tnats are 1. 164 173 165 174 !--- For [3]H 166 175 INTEGER :: iessai 176 177 CHARACTER(LEN=maxlen) :: modname, sxt 167 178 168 179 modname = 'iso_init' … … 176 187 CALL msg('64: niso = '//TRIM(int2str(niso)), modname) 177 188 178 DO ii = 1, nbIso 179 CALL msg('Can''t select isotopes class "'//TRIM(isoFamilies(ii))//'"', modname, isoSelect(ii, lVerbose=.TRUE.)) 180 181 !============================================================================================================================== 182 IF(isoFamilies(ii) == 'H2O') THEN 183 !============================================================================================================================== 184 !--- Init de ntracisoOR: on ecrasera en cas de traceurs de tagging isotopiques 185 ! (nzone>0) si complications avec ORCHIDEE 186 ntracisoOR = ntiso 187 188 !--- Type of water isotopes: 189 iso_eau = strIdx(isoName, 'H216O'); CALL msg('iso_eau='//int2str(iso_eau), modname) 190 iso_HDO = strIdx(isoName, 'HDO'); CALL msg('iso_HDO='//int2str(iso_HDO), modname) 191 iso_O18 = strIdx(isoName, 'H218O'); CALL msg('iso_O18='//int2str(iso_O18), modname) 192 iso_O17 = strIdx(isoName, 'H217O'); CALL msg('iso_O17='//int2str(iso_O17), modname) 193 iso_HTO = strIdx(isoName, 'HTO'); CALL msg('iso_HTO='//int2str(iso_HTO), modname) 194 195 !--- Initialisation: reading the isotopic parameters. 196 CALL get_in('lambda', lambda_sursat, 0.004); IF(ok_nocinsat) lambda_sursat = 0. 197 CALL get_in('thumxt1', thumxt1, 0.75*1.2) 198 CALL get_in('ntot', ntot, 20, .FALSE.) 199 CALL get_in('h_land_ice', h_land_ice, 20., .FALSE.) 200 CALL get_in('P_veg', P_veg, 1.0, .FALSE.) 201 CALL get_in('bidouille_anti_divergence', bidouille_anti_divergence, .FALSE.) 202 CALL get_in('essai_convergence', essai_convergence, .FALSE.) 203 CALL get_in('initialisation_iso', initialisation_iso, 0) 204 205 ! IF(nzone>0 .AND. initialisation_iso==0) & 206 ! CALL get_in('initialisation_isotrac',initialisation_isotrac) 207 CALL get_in('modif_sst', modif_sst, 0) 208 CALL get_in('deltaTtest', deltaTtest, 0.0) !--- For modif_sst>=1 209 CALL get_in('deltaTtestpoles',deltaTtestpoles, 0.0) !--- For modif_sst>=2 210 CALL get_in( 'sstlatcrit', sstlatcrit, 30.0) !--- For modif_sst>=3 211 CALL get_in('dsstlatcrit', dsstlatcrit, 0.0) !--- For modif_sst>=3 189 !--- Init de ntracisoOR: on ecrasera en cas de traceurs de tagging isotopiques 190 ! (nzone>0) si complications avec ORCHIDEE 191 ntracisoOR = ntiso 192 193 !--- Type of water isotopes: 194 iso_eau = strIdx(isoName, 'H216O'); CALL msg('iso_eau='//int2str(iso_eau), modname) 195 iso_HDO = strIdx(isoName, 'HDO'); CALL msg('iso_HDO='//int2str(iso_HDO), modname) 196 iso_O18 = strIdx(isoName, 'H218O'); CALL msg('iso_O18='//int2str(iso_O18), modname) 197 iso_O17 = strIdx(isoName, 'H217O'); CALL msg('iso_O17='//int2str(iso_O17), modname) 198 iso_HTO = strIdx(isoName, 'HTO'); CALL msg('iso_HTO='//int2str(iso_HTO), modname) 199 200 !--- Initialiaation: reading the isotopic parameters. 201 CALL get_in('lambda', lambda_sursat, 0.004) 202 CALL get_in('thumxt1', thumxt1, 0.75*1.2) 203 CALL get_in('ntot', ntot, 20, .FALSE.) 204 CALL get_in('h_land_ice', h_land_ice, 20., .FALSE.) 205 CALL get_in('P_veg', P_veg, 1.0, .FALSE.) 206 CALL get_in('bidouille_anti_divergence', bidouille_anti_divergence, .FALSE.) 207 CALL get_in('essai_convergence', essai_convergence, .FALSE.) 208 CALL get_in('initialisation_iso', initialisation_iso, 0) 209 210 ! IF(nzone>0 .AND. initialisation_iso==0) & 211 ! CALL get_in('initialisation_isotrac',initialisation_isotrac) 212 CALL get_in('modif_sst', modif_sst, 0) 213 CALL get_in('deltaTtest', deltaTtest, 0.0) !--- For modif_sst>=1 214 CALL get_in('deltaTtestpoles',deltaTtestpoles, 0.0) !--- For modif_sst>=2 215 CALL get_in( 'sstlatcrit', sstlatcrit, 30.0) !--- For modif_sst>=3 216 CALL get_in('dsstlatcrit', dsstlatcrit, 0.0) !--- For modif_sst>=3 212 217 #ifdef ISOVERIF 213 214 215 218 CALL msg('iso_init 270: sstlatcrit='//real2str( sstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=2 219 CALL msg('iso_init 279: dsstlatcrit='//real2str(dsstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=3 220 IF(modif_sst >= 2 .AND. sstlatcrit < 0.0) STOP 216 221 #endif 217 222 218 CALL get_in('modif_sic', modif_sic, 0) 219 IF(modif_sic >= 1) & 220 CALL get_in('deltasic', deltasic, 0.1) 221 222 CALL get_in('albedo_prescrit', albedo_prescrit, 0) 223 IF(albedo_prescrit == 1) THEN 224 CALL get_in('lon_min_albedo', lon_min_albedo, -200.) 225 CALL get_in('lon_max_albedo', lon_max_albedo, 200.) 226 CALL get_in('lat_min_albedo', lat_min_albedo, -100.) 227 CALL get_in('lat_max_albedo', lat_max_albedo, 100.) 228 END IF 229 CALL get_in('deltaO18_oce', deltaO18_oce, 0.0) 230 CALL get_in('deltaP_BL', deltaP_BL, 10.0) 231 CALL get_in('ruissellement_pluie', ruissellement_pluie, 0) 232 CALL get_in('alphak_stewart', alphak_stewart, 1) 233 CALL get_in('tdifexp_sol', tdifexp_sol, 0.67) 234 CALL get_in('calendrier_guide', calendrier_guide, 0) 235 CALL get_in('cste_surf_cond', cste_surf_cond, 0) 236 CALL get_in('mixlen', mixlen, 35.0) 237 CALL get_in('evap_cont_cste', evap_cont_cste, 0) 238 CALL get_in('deltaO18_evap_cont', deltaO18_evap_cont,0.0) 239 CALL get_in('d_evap_cont', d_evap_cont, 0.0) 240 CALL get_in('nudge_qsol', nudge_qsol, 0) 241 CALL get_in('region_nudge_qsol', region_nudge_qsol, 1) 242 nlevmaxO17 = 50 243 CALL msg('nlevmaxO17='//TRIM(int2str(nlevmaxO17))) 244 CALL get_in('no_pce', no_pce, 0) 245 CALL get_in('A_satlim', A_satlim, 1.0) 246 CALL get_in('ok_restrict_A_satlim', ok_restrict_A_satlim, 0) 223 CALL get_in('modif_sic', modif_sic, 0) 224 IF(modif_sic >= 1) & 225 CALL get_in('deltasic', deltasic, 0.1) 226 227 CALL get_in('albedo_prescrit', albedo_prescrit, 0) 228 IF(albedo_prescrit == 1) THEN 229 CALL get_in('lon_min_albedo', lon_min_albedo, -200.) 230 CALL get_in('lon_max_albedo', lon_max_albedo, 200.) 231 CALL get_in('lat_min_albedo', lat_min_albedo, -100.) 232 CALL get_in('lat_max_albedo', lat_max_albedo, 100.) 233 END IF 234 CALL get_in('deltaP_BL', deltaP_BL, 10.0) 235 CALL get_in('ruissellement_pluie', ruissellement_pluie, 0) 236 CALL get_in('alphak_stewart', alphak_stewart, 1) 237 CALL get_in('tdifexp_sol', tdifexp_sol, 0.67) 238 CALL get_in('calendrier_guide', calendrier_guide, 0) 239 CALL get_in('cste_surf_cond', cste_surf_cond, 0) 240 CALL get_in('mixlen', mixlen, 35.0) 241 CALL get_in('evap_cont_cste', evap_cont_cste, 0) 242 CALL get_in('deltaO18_evap_cont', deltaO18_evap_cont,0.0) 243 CALL get_in('d_evap_cont', d_evap_cont, 0.0) 244 CALL get_in('nudge_qsol', nudge_qsol, 0) 245 CALL get_in('region_nudge_qsol', region_nudge_qsol, 1) 246 nlevmaxO17 = 50 247 CALL msg('nlevmaxO17='//TRIM(int2str(nlevmaxO17))) 248 CALL get_in('no_pce', no_pce, 0) 249 CALL get_in('A_satlim', A_satlim, 1.0) 250 CALL get_in('ok_restrict_A_satlim', ok_restrict_A_satlim, 0) 247 251 #ifdef ISOVERIF 248 249 252 CALL msg(' 315: A_satlim='//real2str(A_satlim), modname, A_satlim > 1.0) 253 IF(A_satlim > 1.0) STOP 250 254 #endif 251 ! CALL get_in('slope_limiterxy', slope_limiterxy, 2.0) 252 ! CALL get_in('slope_limiterz', slope_limiterz, 2.0) 253 CALL get_in('modif_ratqs', modif_ratqs, 0) 254 CALL get_in('Pcrit_ratqs', Pcrit_ratqs, 500.0) 255 CALL get_in('ratqsbasnew', ratqsbasnew, 0.05) 256 CALL get_in('fac_modif_evaoce', fac_modif_evaoce, 1.0) 257 CALL get_in('ok_bidouille_wake', ok_bidouille_wake, 0) 258 ! si oui, la temperature de cond est celle de l'environnement, pour eviter 259 ! bugs quand temperature dans ascendances convs est mal calculee 260 CALL get_in('cond_temp_env', cond_temp_env, .FALSE.) 261 IF(ANY(isoName == 'HTO')) & 262 CALL get_in('ok_prod_nucl_tritium', ok_prod_nucl_tritium, .FALSE., .FALSE.) 263 CALL get_in('tnateq1', ltnat1, .TRUE.) 264 265 CALL msg('iso_O18, iso_HDO, iso_eau = '//TRIM(strStack(int2str([iso_O18, iso_HDO, iso_eau]))), modname) 266 267 !-------------------------------------------------------------- 268 ! Parameters that depend on the nature of water isotopes: 269 !-------------------------------------------------------------- 270 ALLOCATE(tnat (niso), talph1(niso), talps1(niso), tkcin0(niso), tdifrel (niso), alpha (niso)) 271 ALLOCATE(toce (niso), talph2(niso), talps2(niso), tkcin1(niso), Rdefault(niso), alpha_liq_sol(niso)) 272 ALLOCATE(tcorr(niso), talph3(niso), tkcin2(niso), Rmethox (niso)) 273 274 !=== H216O 275 is = iso_eau 276 IF(is /= 0) THEN 277 tdifrel (is) = 1.0 278 alpha (is) = alpha_ideal_H216O 279 tnat (is) = tnat_H216O; IF(ltnat1) tnat(is) = 1.0 280 toce (is) = tnat(is) 281 tcorr (is) = 1.0 282 talph1 (is) = 0.0; talps1(is) = 0.0; tkcin0(is) = 0.0 283 talph2 (is) = 0.0; talps2(is) = 0.0; tkcin1(is) = 0.0 284 talph3 (is) = 0.0; tkcin2(is) = 0.0 285 Rdefault(is) = tnat(is)*1.0 286 Rmethox (is) = 1.0 287 alpha_liq_sol(is) = 1.0 288 END IF 289 290 !=== H217O 291 is = iso_O17 292 IF(is /= 0) THEN; pente_MWL = 0.528 293 tdifrel (is) = 1./0.98555 ! used in 1D and in LdG model ; tdifrel=1./0.985452: from Amaelle 294 alpha (is) = alpha_ideal_H217O 295 tnat (is) = tnat_H217O; IF(ltnat1) tnat(is) = 1.0 296 toce (is) = tnat(is)*(1.0+deltaO18_oce/1000.0)**pente_MWL 297 tcorr (is) = 1.0+fac_enrichoce18*pente_MWL 298 fac_kcin = (tdifrel(is)-1.0)/(tdifrel_O18-1.0) ! fac_kcin=0.5145: from Amaelle 299 talph1 (is) = talph1_O18; talps1(is) = talps1_O18; tkcin0(is) = tkcin0_O18*fac_kcin 300 talph2 (is) = talph2_O18; talps2(is) = talps2_O18; tkcin1(is) = tkcin1_O18*fac_kcin 301 talph3 (is) = talph3_O18; tkcin2(is) = tkcin2_O18*fac_kcin 302 Rdefault(is) = tnat(is)*(1.0-3.15/1000.) 303 Rmethox (is) = tnat(is)*(1.0+230./1000.) 304 alpha_liq_sol(is) = alpha_liq_sol_O18**fac_coeff_eq17_liq 305 END IF 306 307 !=== H218O 308 is = iso_O18 309 IF(is /= 0) THEN 310 tdifrel (is) = tdifrel_O18 311 alpha (is) = alpha_ideal_H218O 312 tnat (is) = tnat_H218O; IF(ltnat1) tnat(is) = 1.0 313 toce (is) = tnat(is)*(1.0+deltaO18_oce/1000.0) 314 tcorr (is) = 1.0+fac_enrichoce18 315 talph1 (is) = talph1_O18; talps1(is) = talps1_O18; tkcin0(is) = tkcin0_O18 316 talph2 (is) = talph2_O18; talps2(is) = talps2_O18; tkcin1(is) = tkcin1_O18 317 talph3 (is) = talph3_O18; tkcin2(is) = tkcin2_O18 318 Rdefault(is) = tnat(is)*(1.0-6.00/1000.) 319 Rmethox (is) = tnat(is)*(1.0+130./1000.) ! Zahn & al. 2006 320 alpha_liq_sol(is) = alpha_liq_sol_O18 321 END IF 322 323 !=== HDO 324 is = iso_HDO 325 IF(is /= 0) THEN; pente_MWL = 8.0 326 tdifrel (is) = 1./0.9755 ! fac_kcin=0.88 327 alpha (is) = alpha_ideal_HDO 328 tnat (is) = tnat_HDO; IF(ltnat1) tnat(is) = 1.0 329 toce (is) = tnat(is)*(1.0+deltaO18_oce/1000.0*pente_MWL) 330 tcorr (is) = 1.0+fac_enrichoce18*pente_MWL 331 fac_kcin = (tdifrel(is)-1.0)/(tdifrel_O18-1.0) 332 talph1 (is) = 24844.; talps1(is) = 16288.; tkcin0(is) = tkcin0_O18*fac_kcin 333 talph2 (is) = -76.248; talps2(is) = -0.0934; tkcin1(is) = tkcin1_O18*fac_kcin 334 talph3 (is) = 52.612E-3; tkcin2(is) = tkcin2_O18*fac_kcin 335 Rdefault(is) = tnat(is)*(1.0+(10.0-6.0*pente_MWL)/1000.) 336 Rmethox (is) = tnat(is)*(1.0-25.0/1000.) 337 alpha_liq_sol(is) = 1.0212 ! Lehmann & Siegenthaler, 1991, Jo. of Glaciology, vol 37, p 23 338 ! alpha_liq_sol=1.0192: Weston, Ralph, 1955 339 END IF 340 341 !=== HTO 342 is = iso_HTO 343 IF(is /= 0) THEN 344 tdifrel (is) = 1./0.968 345 alpha (is) = alpha_ideal_HTO 346 tnat (is) = tnat_HTO; IF(ltnat1) tnat(is) = 1.0 347 toce (is) = 4.0E-19 ! ratio T/H = 0.2 TU Dreisigacker & Roether 1978 348 tcorr (is) = 1.0 349 talph1 (is) = 46480.; talps1(is) = 46480.; tkcin0(is) = 0.01056 350 talph2 (is) = -103.87; talps2(is) = -103.87; tkcin1(is) = 0.0005016 351 talph3 (is) = 0.0; tkcin2(is) = 0.0014432 352 Rdefault(is) = 0.0 353 Rmethox (is) = 0.0 354 alpha_liq_sol(is) = 1.0 355 END IF 356 357 IF(.NOT. Rdefault_smow) THEN 358 Rdefault(:) = 0.0; IF(iso_eau > 0) Rdefault(iso_eau) = 1.0 359 END IF 360 WRITE(*,*) 'Rdefault = ',Rdefault 361 WRITE(*,*) 'toce = ', toce 362 363 !--- Sensitivity test: no kinetic effect in sfc evaporation 364 IF(ok_nocinsfc) THEN 365 tkcin0(1:niso) = 0.0 366 tkcin1(1:niso) = 0.0 367 tkcin2(1:niso) = 0.0 368 END IF 369 370 CALL msg('285: verif initialisation:', modname) 371 DO ixt=1,niso 372 sxt=int2str(ixt) 373 CALL msg(' * isoName('//TRIM(sxt)//') = <'//TRIM(isoName(ixt))//'>', modname) 374 CALL msg( ' tnat('//TRIM(sxt)//') = '//TRIM(real2str(tnat(ixt))), modname) 375 ! CALL msg(' alpha_liq_sol('//TRIM(sxt)//') = '//TRIM(real2str(alpha_liq_sol(ixt))), modname) 376 ! CALL msg( ' tkcin0('//TRIM(sxt)//') = '//TRIM(real2str(tkcin0(ixt))), modname) 377 ! CALL msg( ' tdifrel('//TRIM(sxt)//') = '//TRIM(real2str(tdifrel(ixt))), modname) 378 END DO 379 CALL msg('69: lambda = '//TRIM(real2str(lambda_sursat)), modname) 380 CALL msg('69: thumxt1 = '//TRIM(real2str(thumxt1)), modname) 381 CALL msg('69: h_land_ice = '//TRIM(real2str(h_land_ice)), modname) 382 CALL msg('69: P_veg = '//TRIM(real2str(P_veg)), modname) 383 !============================================================================================================================== 384 ELSE 385 !============================================================================================================================== 386 CALL abort_physic('"isotopes_mod" is not set up yet for isotopes family "'//TRIM(isoFamilies(ii))//'"', modname, 1) 387 !============================================================================================================================== 388 END IF 389 !============================================================================================================================== 255 ! CALL get_in('slope_limiterxy', slope_limiterxy, 2.0) 256 ! CALL get_in('slope_limiterz', slope_limiterz, 2.0) 257 CALL get_in('modif_ratqs', modif_ratqs, 0) 258 CALL get_in('Pcrit_ratqs', Pcrit_ratqs, 500.0) 259 CALL get_in('ratqsbasnew', ratqsbasnew, 0.05) 260 CALL get_in('fac_modif_evaoce', fac_modif_evaoce, 1.0) 261 CALL get_in('ok_bidouille_wake', ok_bidouille_wake, 0) 262 ! si oui, la temperature de cond est celle de l'environnement, pour eviter 263 ! bugs quand temperature dans ascendances convs est mal calculee 264 CALL get_in('cond_temp_env', cond_temp_env, .FALSE.) 265 IF(ANY(isoName == 'HTO')) & 266 CALL get_in('ok_prod_nucl_tritium', ok_prod_nucl_tritium, .FALSE., .FALSE.) 267 268 ! Ocean composition 269 CALL get_in('deltaO18_oce', deltaO18_oce, 0.0) 270 271 CALL msg('iso_O18, iso_HDO, iso_eau = '//TRIM(strStack(int2str([iso_O18, iso_HDO, iso_eau]))), modname) 272 273 !-------------------------------------------------------------- 274 ! Isotope fractionation factors and a few isotopic constants 275 !-------------------------------------------------------------- 276 ALLOCATE(tkcin0(niso)) 277 ALLOCATE(tkcin1(niso)) 278 ALLOCATE(tkcin2(niso)) 279 ALLOCATE(tnat(niso)) 280 ALLOCATE(tdifrel(niso)) 281 ALLOCATE(toce(niso)) 282 ALLOCATE(tcorr(niso)) 283 ALLOCATE(talph1(niso)) 284 ALLOCATE(talph2(niso)) 285 ALLOCATE(talph3(niso)) 286 ALLOCATE(talps1(niso)) 287 ALLOCATE(talps2(niso)) 288 ALLOCATE(alpha_liq_sol(niso)) 289 ALLOCATE(Rdefault(niso)) 290 ALLOCATE(Rmethox(niso)) 291 292 do ixt=1,niso 293 if (ixt.eq.iso_HTO) then ! Tritium 294 tkcin0(ixt) = 0.01056 295 tkcin1(ixt) = 0.0005016 296 tkcin2(ixt) = 0.0014432 297 if (tnat1) then 298 tnat(ixt)=1 299 else 300 tnat(ixt)=0. 301 endif 302 toce(ixt)=4.0E-19 ! rapport T/H = 0.2 TU Dreisigacker and Roether 1978 303 tcorr(ixt)=1. 304 tdifrel(ixt)=1./0.968 305 talph1(ixt)=46480. 306 talph2(ixt)=-103.87 307 talph3(ixt)=0. 308 talps1(ixt)=46480. 309 talps2(ixt)=-103.87 310 alpha_liq_sol(ixt)=1. 311 Rmethox(ixt)=0.0 312 endif 313 if (ixt.eq.iso_O17) then ! O17 314 pente_MWL=0.528 315 tdifrel(ixt)=1./0.98555 ! valeur utilisée en 1D et dans modèle de LdG ! tdifrel(ixt)=1./0.985452 ! donné par Amaelle 316 fac_kcin= (tdifrel(ixt)-1.0)/(tdifrel_O18-1.0) ! fac_kcin=0.5145 ! donné par Amaelle 317 tkcin0(ixt) = tkcin0_O18*fac_kcin 318 tkcin1(ixt) = tkcin1_O18*fac_kcin 319 tkcin2(ixt) = tkcin2_O18*fac_kcin 320 if (tnat1) then 321 tnat(ixt)=1 322 else 323 tnat(ixt)=0.004/100. ! O17 représente 0.004% de l'oxygène 324 endif 325 toce(ixt)=tnat(ixt)*(1.0+deltaO18_oce/1000.0)**pente_MWL 326 tcorr(ixt)=1.0+fac_enrichoce18*pente_MWL ! donné par Amaelle 327 talph1(ixt)=talph1_O18 328 talph2(ixt)=talph2_O18 329 talph3(ixt)=talph3_O18 330 talps1(ixt)=talps1_O18 331 talps2(ixt)=talps2_O18 332 alpha_liq_sol(ixt)=(alpha_liq_sol_O18)**fac_coeff_eq17_liq 333 Rdefault(ixt)=tnat(ixt)*(-3.15/1000.0+1.0) 334 Rmethox(ixt)=(230./1000.+1.)*tnat(ixt) !Zahn et al 2006 335 endif 336 if (ixt.eq.iso_O18) then ! Oxygene18 337 tkcin0(ixt) = tkcin0_O18 338 tkcin1(ixt) = tkcin1_O18 339 tkcin2(ixt) = tkcin2_O18 340 if (tnat1) then 341 tnat(ixt)=1 342 else 343 tnat(ixt)=2005.2E-6 344 endif 345 toce(ixt)=tnat(ixt)*(1.0+deltaO18_oce/1000.0) 346 tcorr(ixt)=1.0+fac_enrichoce18 347 tdifrel(ixt)=tdifrel_O18 348 talph1(ixt)=talph1_O18 349 talph2(ixt)=talph2_O18 350 talph3(ixt)=talph3_O18 351 talps1(ixt)=talps1_O18 352 talps2(ixt)=talps2_O18 353 alpha_liq_sol(ixt)=alpha_liq_sol_O18 354 Rdefault(ixt)=tnat(ixt)*(-6.0/1000.0+1.0) 355 Rmethox(ixt)=(130./1000.+1.)*tnat(ixt) !Zahn et al 2006 356 endif 357 if (ixt.eq.iso_HDO) then ! Deuterium 358 pente_MWL=8.0 359 tdifrel(ixt)=1./0.9755 ! fac_kcin=0.88 360 fac_kcin= (tdifrel(ixt)-1)/(tdifrel_O18-1) 361 tkcin0(ixt) = tkcin0_O18*fac_kcin 362 tkcin1(ixt) = tkcin1_O18*fac_kcin 363 tkcin2(ixt) = tkcin2_O18*fac_kcin 364 if (tnat1) then 365 tnat(ixt)=1 366 else 367 tnat(ixt)=155.76E-6 368 endif 369 toce(ixt)=tnat(ixt)*(1.0+pente_MWL*deltaO18_oce/1000.0) 370 tcorr(ixt)=1.0+fac_enrichoce18*pente_MWL 371 talph1(ixt)=24844. 372 talph2(ixt)=-76.248 373 talph3(ixt)=52.612E-3 374 talps1(ixt)=16288. 375 talps2(ixt)=-0.0934 376 !ZXalpha_liq_sol=1.0192 ! Weston, Ralph, 1955 377 alpha_liq_sol(ixt)=1.0212 378 ! valeur de Lehmann & Siegenthaler, 1991, Journal of 379 ! Glaciology, vol 37, p 23 380 Rdefault(ixt)=tnat(ixt)*((-6.0*pente_MWL+10.0)/1000.0+1.0) 381 Rmethox(ixt)=tnat(ixt)*(-25.0/1000.+1.) ! Zahn et al 2006 382 endif 383 if (ixt.eq.iso_eau) then ! Oxygene16 384 tkcin0(ixt) = 0.0 385 tkcin1(ixt) = 0.0 386 tkcin2(ixt) = 0.0 387 tnat(ixt)=1. 388 toce(ixt)=tnat(ixt) 389 tcorr(ixt)=1.0 390 tdifrel(ixt)=1. 391 talph1(ixt)=0. 392 talph2(ixt)=0. 393 talph3(ixt)=0. 394 talps1(ixt)=0. 395 talph3(ixt)=0. 396 alpha_liq_sol(ixt)=1. 397 Rdefault(ixt)=tnat(ixt)*1.0 398 Rmethox(ixt)=1.0 399 endif 400 enddo ! ixt=1,niso 401 402 IF(.NOT.Rdefault_smow) then 403 Rdefault(:) = 0.0 404 if (iso_eau.gt.0) Rdefault(iso_eau) = 1.0 ! correction Camille 30 mars 2023 405 ENDIF 406 write(*,*) 'Rdefault=',Rdefault 407 write(*,*) 'toce=',toce 408 409 !--- Sensitivity test: no kinetic effect in sfc evaporation 410 IF(ok_nocinsfc) THEN 411 tkcin0(1:niso) = 0.0 412 tkcin1(1:niso) = 0.0 413 tkcin2(1:niso) = 0.0 414 END IF 415 416 CALL msg('285: verif initialisation:', modname) 417 DO ixt=1,niso 418 sxt=int2str(ixt) 419 CALL msg(' * isoName('//TRIM(sxt)//') = <'//TRIM(isoName(ixt))//'>', modname) 420 CALL msg( ' tnat('//TRIM(sxt)//') = '//TRIM(real2str(tnat(ixt))), modname) 421 ! CALL msg(' alpha_liq_sol('//TRIM(sxt)//') = '//TRIM(real2str(alpha_liq_sol(ixt))), modname) 422 ! CALL msg( ' tkcin0('//TRIM(sxt)//') = '//TRIM(real2str(tkcin0(ixt))), modname) 423 ! CALL msg( ' tdifrel('//TRIM(sxt)//') = '//TRIM(real2str(tdifrel(ixt))), modname) 390 424 END DO 425 CALL msg('69: lambda = '//TRIM(real2str(lambda_sursat)), modname) 426 CALL msg('69: thumxt1 = '//TRIM(real2str(thumxt1)), modname) 427 CALL msg('69: h_land_ice = '//TRIM(real2str(h_land_ice)), modname) 428 CALL msg('69: P_veg = '//TRIM(real2str(P_veg)), modname) 391 429 392 430 END SUBROUTINE iso_init -
LMDZ6/trunk/libf/phylmdiso/isotopes_routines_mod.F90
r5183 r5190 16419 16419 USE isotopes_mod, ONLY: isoName,iso_HDO,iso_eau 16420 16420 USE phyetat0_get_mod, ONLY: phyetat0_get, phyetat0_srf 16421 USE infotrac_phy,ONLY: new2oldH2O16422 USE strings_mod, ONLY: strIdx, str Head, strTail, maxlen, msg, int2str16421 USE readTracFiles_mod, ONLY: new2oldH2O 16422 USE strings_mod, ONLY: strIdx, strTail, maxlen, msg, int2str 16423 16423 #ifdef ISOVERIF 16424 16424 USE isotopes_verif_mod … … 16459 16459 outiso = isoName(ixt) 16460 16460 oldIso = strTail(new2oldH2O(outiso), '_') !--- Remove "H2O_" from "H2O_<iso>[_<tag>]" 16461 oldIso2= TRIM(strHead(outiso,'_'))//strTail(outiso,'_') ! CR 2023: most recent possibility 16461 i = INDEX(outiso, '_', .TRUE.) 16462 oldIso2 = outiso(1:i-1)//outiso(i+1:LEN_TRIM(outiso)) ! CR 2023: on ajoute cette possibilité aussi, elle correspond au cas le plus récent. 16462 16463 ! write(*,*) 'tmp 16541:' 16463 16464 ! write(*,*) 'outiso=',outiso -
LMDZ6/trunk/libf/phylmdiso/isotrac_mod.F90
r5183 r5190 3 3 4 4 MODULE isotrac_mod 5 USE infotrac_phy, ONLY: niso, ntiso, nzone, delPhase 6 USE isotopes_mod, ONLY: ridicule, get_in 5 USE infotrac_phy, ONLY: niso, ntiso, nzone 6 USE readTracFiles_mod, ONLY: delPhase 7 USE isotopes_mod, ONLY: ridicule, get_in 7 8 8 9 IMPLICIT NONE -
LMDZ6/trunk/libf/phylmdiso/phyetat0_mod.F90
r5183 r5190 40 40 USE geometry_mod, ONLY: longitude_deg, latitude_deg 41 41 USE iostart, ONLY: close_startphy, get_field, get_var, open_startphy 42 USE infotrac_phy, ONLY: nqtot, nbtr, type_trac, tracers , new2oldH2O43 USE strings_mod, ONLY: maxlen42 USE infotrac_phy, ONLY: nqtot, nbtr, type_trac, tracers 43 USE readTracFiles_mod,ONLY: maxlen, new2oldH2O 44 44 USE traclmdz_mod, ONLY: traclmdz_from_restart 45 45 USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo -
LMDZ6/trunk/libf/phylmdiso/physiq_mod.F90
r5189 r5190 39 39 USE ioipsl_getin_p_mod, ONLY : getin_p 40 40 USE indice_sol_mod 41 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac,addPhase, ivap, iliq, isol 41 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac,ivap,iliq,isol 42 USE readTracFiles_mod, ONLY: addPhase 42 43 USE strings_mod, ONLY: strIdx 43 44 USE iophy … … 2623 2624 ENDDO 2624 2625 ENDDO 2625 2626 ! Lea Raillard qs_ini for cloud phase param.2627 qs_ini(:,:)=qs_seri(:,:)2628 2626 2629 2627 ! C Risi: dispatcher les isotopes dans les xt_seri … … 7144 7142 ENDDO 7145 7143 ENDDO 7144 7145 ! Lea Raillard qs_ini for cloud phase param. 7146 qs_ini(:,:)=qs_seri(:,:) 7146 7147 7147 7148 ! C Risi: dispatcher les isotopes dans les xt_seri
Note: See TracChangeset
for help on using the changeset viewer.