- Timestamp:
- Apr 5, 2022, 3:44:30 PM (3 years ago)
- Location:
- LMDZ6/trunk/libf
- Files:
-
- 15 edited
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/dyn3d/dynetat0.F90
r4119 r4120 6 6 ! Purpose: Initial state reading. 7 7 !------------------------------------------------------------------------------- 8 USE infotrac, ONLY: nqtot, tracers, iqiso, iso_indnum, tnat, alpha_ideal, &9 ok_isotopes10 USE strings_mod, ONLY: maxlen11 USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQ_VARID, NF90_NoErr, &12 NF90_CLOSE, NF90_GET_VAR8 USE infotrac, ONLY: nqtot, tracers, niso, iqiso, iso_indnum, iso_num, tnat, alpha_ideal, ok_isotopes, iH2O 9 USE strings_mod, ONLY: maxlen, msg, strStack, real2str 10 USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQ_VARID, & 11 NF90_CLOSE, NF90_GET_VAR, NF90_NoErr 12 USE readTracFiles_mod, ONLY: new2oldName 13 13 USE control_mod, ONLY: planet_type 14 14 USE assert_eq_m, ONLY: assert_eq … … 38 38 !=============================================================================== 39 39 ! Local variables: 40 CHARACTER(LEN=maxlen) :: m sg, var, modname40 CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar 41 41 INTEGER, PARAMETER :: length=100 42 42 INTEGER :: iq, fID, vID, idecal, iqParent, iName, iZone, iPhase … … 53 53 !!! .... while keeping everything OK for LMDZ EARTH 54 54 IF(planet_type=="generic") THEN 55 WRITE(lunout,*)'NOTE NOTE NOTE : Planeto-like start files'55 CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname) 56 56 idecal = 4 57 57 annee_ref = 2000 58 58 ELSE 59 WRITE(lunout,*)'NOTE NOTE NOTE : Earth-like start files'59 CALL msg('NOTE NOTE NOTE : Earth-like start files', modname) 60 60 idecal = 5 61 61 annee_ref = tab_cntrl(5) … … 101 101 102 102 !------------------------------------------------------------------------------- 103 WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa103 CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname) 104 104 CALL check_dim(im,iim,'im','im') 105 105 CALL check_dim(jm,jjm,'jm','jm') … … 114 114 var="temps" 115 115 IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN 116 WRITE(lunout,*)TRIM(modname)//": missing field <temps>"117 WRITE(lunout,*)TRIM(modname)//": trying with <Time>";var="Time"116 CALL msg('missing field <temps> ; trying with <Time>', modname) 117 var="Time" 118 118 CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var) 119 119 END IF … … 128 128 !--- Tracers 129 129 DO iq=1,nqtot 130 var=TRIM(tracers(iq)%name) 131 IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN 132 CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var); CYCLE 130 var = tracers(iq)%name 131 oldVar = new2oldName(var) 132 !-------------------------------------------------------------------------------------------------------------------------- 133 IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr) THEN !=== REGULAR CASE 134 CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var) 135 !-------------------------------------------------------------------------------------------------------------------------- 136 ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN !=== OLD NAME 137 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname) 138 CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",oldVar) 139 !-------------------------------------------------------------------------------------------------------------------------- 140 #ifdef INCA 141 ELSE IF(NF90_INQ_VARID(fID, 'OX', vID) == NF90_NoErr .AND. var == 'O3') THEN !=== INCA: OX INSTEAD OF O3 142 CALL msg('Tracer <O3> is missing => initialized to <OX>', modname) 143 CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",'OX') 144 !-------------------------------------------------------------------------------------------------------------------------- 145 #endif 146 ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN !=== WATER ISOTOPES 147 ! iName = tracers(iq)%iso_iName ! (next commit) 148 iName = iso_num(iq) 149 iPhase = tracers(iq)%iso_iPhase 150 iqParent = tracers(iq)%iqParent 151 IF(tracers(iq)%iso_iZone == 0) THEN 152 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname) 153 q(:,:,:,iq) = q(:,:,:,iqParent)*tnat(iName)*(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.) 154 ELSE 155 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to its parent isotope concentration.', modname) 156 q(:,:,:,iq) = q(:,:,:,iqiso(iso_indnum(iq),iPhase)) 157 END IF 158 !-------------------------------------------------------------------------------------------------------------------------- 159 ELSE !=== MISSING: SET TO 0 160 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to zero', modname) 161 q(:,:,:,iq)=0. 162 !-------------------------------------------------------------------------------------------------------------------------- 133 163 END IF 134 WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"135 WRITE(lunout,*)" It is hence initialized to zero"136 q(:,:,:,iq)=0.137 !--- CRisi: for isotops, theoretical initialization using very simplified138 ! Rayleigh distillation law.139 iName = tracers(iq)%iso_iName140 IF(.NOT.ok_isotopes .OR. iName<=0) CYCLE141 iZone = tracers(iq)%iso_iZone142 iPhase= tracers(iq)%iso_iPhase143 iqParent = tracers(iq)%iqParent144 IF(iZone==0) q(:,:,:,iq) = q(:,:,:,iqParent)*tnat(iName) &145 *(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.)146 IF(iZone==1) q(:,:,:,iq) = q(:,:,:,iqiso(iso_indnum(iq),iPhase))147 164 END DO 148 165 … … 162 179 s1='value of '//TRIM(str1)//' =' 163 180 s2=' read in starting file differs from parametrized '//TRIM(str2)//' =' 164 WRITE(m sg,'(10x,a,i4,2x,a,i4)')TRIM(ADJUSTL(s1)),n1,TRIM(ADJUSTL(s2)),n2165 CALL ABORT_gcm(TRIM(modname),TRIM(m sg),1)181 WRITE(mesg,'(10x,a,i4,2x,a,i4)')TRIM(ADJUSTL(s1)),n1,TRIM(ADJUSTL(s2)),n2 182 CALL ABORT_gcm(TRIM(modname),TRIM(mesg),1) 166 183 END IF 167 184 END SUBROUTINE check_dim … … 198 215 IF(ierr==NF90_NoERR) RETURN 199 216 SELECT CASE(typ) 200 CASE('inq'); m sg="Field <"//TRIM(nam)//"> is missing"201 CASE('get'); m sg="Reading failed for <"//TRIM(nam)//">"202 CASE('open'); m sg="File opening failed for <"//TRIM(nam)//">"203 CASE('close'); m sg="File closing failed for <"//TRIM(nam)//">"217 CASE('inq'); mesg="Field <"//TRIM(nam)//"> is missing" 218 CASE('get'); mesg="Reading failed for <"//TRIM(nam)//">" 219 CASE('open'); mesg="File opening failed for <"//TRIM(nam)//">" 220 CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">" 204 221 END SELECT 205 CALL ABORT_gcm(TRIM(modname),TRIM(m sg),1)222 CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr) 206 223 END SUBROUTINE err 207 224 -
LMDZ6/trunk/libf/dyn3d/iniacademic.F90
r4056 r4120 6 6 USE filtreg_mod, ONLY: inifilr 7 7 USE infotrac, ONLY: nqtot, niso_possibles, ok_isotopes, ok_iso_verif, tnat, alpha_ideal, & 8 iqiso, tracers, iso_indnum 8 iqiso, tracers, iso_indnum, iso_num 9 9 USE control_mod, ONLY: day_step,planet_type 10 10 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 25 26 ! Author: Frederic Hourdin original: 15/01/93 … … 62 63 real tetastrat ! potential temperature in the stratosphere, in K 63 64 real tetajl(jjp1,llm) 64 INTEGER i,j,l,lsup,ij, iq, iName, i Zone, iPhase, iqParent65 INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent 65 66 66 67 REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T … … 276 277 do iq=1,nqtot 277 278 q(:,:,iq)=0. 278 ! IF(tracers(iq)%name == 'H2O'//phases_sep//'g') q(:,:,iq)=1.e-10 279 ! IF(tracers(iq)%name == 'H2O'//phases_sep//'l') q(:,:,iq)=1.e-15 280 IF(tracers(iq)%name == 'H2Ov') q(:,:,iq)=1.e-10 281 IF(tracers(iq)%name == 'H2Ol') q(:,:,iq)=1.e-15 279 IF(tracers(iq)%name == addPhase('H2O', 'g')) q(:,:,iq)=1.e-10 280 IF(tracers(iq)%name == addPhase('H2O', 'l')) q(:,:,iq)=1.e-15 282 281 283 282 ! CRisi: init des isotopes 284 283 ! distill de Rayleigh très simplifiée 285 iName = tracers(iq)%iso_iName 284 ! iName = tracers(iq)%iso_iName ! (next commit) 285 iName = iso_num(iq) 286 286 if (.NOT.ok_isotopes .OR. iName <= 0) CYCLE 287 iZone = tracers(iq)%iso_iZone288 287 iPhase = tracers(iq)%iso_iPhase 289 288 iqParent = tracers(iq)%iqParent 290 if (iZone == 0) q(:,:,iq) = q(:,:,iqParent)*tnat(iName) & 291 *(q(:,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1) 292 if (iZone == 1) q(:,:,iq) = q(:,:,iqiso(iso_indnum(iq),iPhase)) 289 IF(tracers(iq)%iso_iZone == 0) THEN 290 q(:,:,iq) = q(:,:,iqParent)*tnat(iName)*(q(:,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.) 291 ELSE 292 q(:,:,iq) = q(:,:,iqiso(iso_indnum(iq),iPhase)) 293 END IF 293 294 enddo 294 295 else -
LMDZ6/trunk/libf/dyn3d/leapfrog.F
r3947 r4120 451 451 c+jld 452 452 453 c Diagnostique de conservation de l' énergie : initialisation453 c Diagnostique de conservation de l'energie : initialisation 454 454 IF (ip_ebil_dyn.ge.1 ) THEN 455 455 ztit='bil dyn' … … 498 498 499 499 c 500 c Diagnostique de conservation de l' énergie : difference500 c Diagnostique de conservation de l'energie : difference 501 501 IF (ip_ebil_dyn.ge.1 ) THEN 502 502 ztit='bil phys' -
LMDZ6/trunk/libf/dyn3d_common/infotrac.F90
r4082 r4120 3 3 MODULE infotrac 4 4 5 USE strings_mod, ONLY: msg, find, strIdx, strFind, strParse, dispTable, int2str, reduceExpr, 5 USE strings_mod, ONLY: msg, find, strIdx, strFind, strParse, dispTable, int2str, reduceExpr, & 6 6 cat, fmsg, test, strTail, strHead, strStack, strReduce, bool2str, maxlen, testFile 7 USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, addPhase, phases_sep, nphases, ancestor, & 8 isot_type, readIsotopesFile, delPhase, old_phases, getKey_init, tran0, & 9 keys_type, initIsotopes, indexUpdate, known_phases, getKey, setGeneration, & 10 new2oldPhase 11 7 USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, addPhase, indexUpdate, nphases, ancestor, & 8 isot_type, old2newName, delPhase, getKey_init, tran0, & 9 keys_type, initIsotopes, getPhase, known_phases, getKey, setGeneration 12 10 IMPLICIT NONE 13 11 … … 23 21 PUBLIC :: isotopes, nbIso !--- Derived type, full isotopes families database + nb of families 24 22 PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index 25 PUBLIC :: min_qParent, min_qMass, min_ratio !--- Min. values for various isotopic quantities26 23 !=== FOR ISOTOPES: Specific to water 27 24 PUBLIC :: iH2O, tnat, alpha_ideal !--- H2O isotopes index, natural abundance, fractionning coeff. 25 PUBLIC :: min_qParent, min_qMass, min_ratio !--- Min. values for various isotopic quantities 28 26 !=== FOR ISOTOPES: Depending on the selected isotopes family 29 27 PUBLIC :: isotope, isoKeys !--- Selected isotopes database + associated keys (cf. getKey) 30 28 PUBLIC :: isoName, isoZone, isoPhas !--- Isotopes and tagging zones names, phases 31 29 PUBLIC :: niso, nzone, nphas, ntiso !--- " " numbers + isotopes & tagging tracers number 32 PUBLIC :: iZonIso, iTraPha !--- 2D index tables to get "iq" index 30 PUBLIC :: itZonIso, index_trac !--- idx "it" (in "isoName(1:niso)") = function(tagging idx, isotope idx) 31 PUBLIC :: iqTraPha, iqiso !--- idx "iq" (in "qx") = function(isotope idx, phase idx) + aliases 33 32 PUBLIC :: isoCheck !--- Run isotopes checking routines 34 33 !=== FOR BOTH TRACERS AND ISOTOPES 35 34 PUBLIC :: getKey !--- Get a key from "tracers" or "isotope" 36 35 37 PUBLIC :: ntraciso, ntraceurs_zone, iqiso 38 PUBLIC :: ok_isotopes, ok_iso_verif, ok_isotrac, ok_init_iso, use_iso 39 PUBLIC :: index_trac, iso_indnum, indnum_fn_num, niso_possibles 36 !=== OLD QUANTITIES OR ALIASES FOR OLDER NAMES (TO BE REMOVED SOON) 37 PUBLIC :: ntraciso, ntraceurs_zone 38 PUBLIC :: ok_isotopes, ok_iso_verif, ok_isotrac, use_iso 39 PUBLIC :: iso_num, iso_indnum, indnum_fn_num, niso_possibles 40 40 PUBLIC :: qperemin, masseqmin, ratiomin 41 41 … … 93 93 !=== DERIVED TYPE EMBEDDING MOST OF THE ISOTOPES-RELATED QUANTITIES (LENGTH: nbIso, NUMBER OF ISOTOPES FAMILIES) 94 94 ! Each entry is accessible using "%" sign. 95 ! |-----------------+--------------------------------------------------+----------------+-----------------+ 96 ! | entry | length | Meaning | Former name | Possible values | 97 ! |-----------------+--------------------------------------------------+----------------+-----------------+ 98 ! | parent | Parent tracer (isotopes family name) | | | 99 ! | keys | niso | Isotopes keys/values pairs list + number | | | 100 ! | trac | ntiso | Isotopes + tagging tracers list + number | | | 101 ! | zone | nzone | Geographic tagging zones list + number | | | 102 ! | phase | nphas | Phases list + number | | [g][l][s], 1:3 | 103 ! | niso | Number of isotopes, excluding tagging tracers | | | 104 ! | ntiso | Number of isotopes, including tagging tracers | ntraciso | | 105 ! | nzone | Number of geographic tagging zones | ntraceurs_zone | | 106 ! | nphas | Number of phases | | | 107 ! | iTraPha | Index in "trac(1:niso)" = f(name(1:ntiso)),phas) | iqiso | 1:niso | 108 ! | iZonIso | Index in "trac(1:ntiso)" = f(zone, name(1:niso)) | index_trac | 1:nzone | 109 ! |-----------------+--------------------------------------------------+----------------+-----------------+ 95 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 96 ! | entry | length | Meaning | Former name | Possible values | 97 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 98 ! | parent | Parent tracer (isotopes family name) | | | 99 ! | keys | niso | Isotopes keys/values pairs list + number | | | 100 ! | trac | ntiso | Isotopes + tagging tracers list + number | / | ntraciso | | 101 ! | zone | nzone | Geographic tagging zones list + number | / | ntraceurs_zone | | 102 ! | phase | nphas | Phases list + number | | [g][l][s], 1:3 | 103 ! | iqTraPha | Index in "qx" = f(name(1:ntiso)),phas) | iqiso | 1:nqtot | 104 ! | itZonIso | Index in "trac(1:ntiso)"= f(zone, name(1:niso)) | index_trac | 1:ntiso | 105 ! +-----------------+--------------------------------------------------+--------------------+-----------------+ 110 106 111 107 REAL, PARAMETER :: min_qParent = 1.e-30, min_qMass = 1.e-18, min_ratio = 1.e-16 ! MVals et CRisi … … 127 123 TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR 128 124 INTEGER, SAVE :: ixIso, iH2O !--- Index of the selected isotopes family and H2O family 129 LOGICAL, SAVE 125 LOGICAL, SAVE, POINTER :: isoCheck !--- Flag to trigger the checking routines 130 126 TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName) 131 127 CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY 132 128 isoZone(:), & !--- TAGGING ZONES FOR THE CURRENTLY SELECTED FAMILY 133 129 isoPhas !--- USED PHASES FOR THE CURRENTLY SELECTED FAMILY 134 INTEGER, TARGET, SAVE :: niso, nzone, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES 135 nphas, ntiso !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS 136 INTEGER, SAVE, POINTER :: iZonIso(:,:) !--- INDEX IN "isoTrac" AS f(tagging zone, isotope) 137 INTEGER, SAVE, POINTER :: iTraPha(:,:) !--- INDEX IN "isoTrac" AS f(isotopic tracer, phase) 138 INTEGER, ALLOCATABLE, SAVE :: index_trac(:,:) ! numero ixt en fn izone, indnum entre 1 et niso 139 INTEGER, ALLOCATABLE, SAVE :: iqiso(:,:) ! donne indice iq en fn de (ixt,phase) 140 141 !--- Aliases for older names 142 INTEGER, POINTER, SAVE :: ntraciso, ntraceurs_zone 143 REAL, SAVE :: qperemin, masseqmin, ratiomin 144 145 ! CRisi: cas particulier des isotopes 146 INTEGER, PARAMETER :: niso_possibles = 5 147 LOGICAL, SAVE :: ok_isotopes, ok_iso_verif, ok_isotrac, ok_init_iso 130 INTEGER, SAVE, POINTER :: niso, nzone, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES 131 nphas, ntiso, & !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS 132 itZonIso(:,:), & !--- INDEX IN "isoTrac" AS f(tagging zone idx, isotope idx) 133 iqTraPha(:,:) !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) 134 135 !--- Aliases for older names + quantities to be removed soon 136 INTEGER, SAVE, POINTER :: index_trac(:,:) ! numero ixt en fn izone, indnum entre 1 et niso 137 INTEGER, SAVE, POINTER :: iqiso(:,:) ! donne indice iq en fn de (ixt,phase) 138 INTEGER, SAVE, POINTER :: ntraciso, ntraceurs_zone 139 REAL, SAVE :: qperemin, masseqmin, ratiomin 140 INTEGER, SAVE :: niso_possibles 141 LOGICAL, SAVE :: ok_isotopes, ok_iso_verif, ok_isotrac 148 142 LOGICAL, SAVE, ALLOCATABLE :: use_iso(:) 149 INTEGER, SAVE, ALLOCATABLE :: iso_indnum(:) !--- Gives 1<=idx<=niso_possibles as function(1<=iq <=nqtot) 150 INTEGER, SAVE, ALLOCATABLE :: indnum_fn_num(:) !--- Gives 1<=idx<=niso as function(1<=idx<=niso_possibles) 143 INTEGER, SAVE, ALLOCATABLE :: iso_num(:) !--- idx in [1,niso_possibles] = f(1<=iq <=nqtot) 144 INTEGER, SAVE, ALLOCATABLE :: iso_indnum(:) !--- idx in [1,niso] = f(1<=iq <=nqtot) 145 INTEGER, SAVE, ALLOCATABLE :: indnum_fn_num(:) !--- idx in [1,niso] = f(1<=idx<=niso_possibles) 151 146 152 147 !=== VARIABLES FOR ISOTOPES INITIALIZATION AND FOR INCA 153 REAL, SAVE, ALLOCATABLE :: tnat(:),& !--- Natural relative abundance of water isotope (niso)154 alpha_ideal(:)!--- Ideal fractionning coefficient (for initial state) (niso)155 INTEGER, SAVE, ALLOCATABLE :: conv_flg(:),& !--- Convection activation ; needed for INCA (nbtr)156 pbl_flg(:)!--- Boundary layer activation ; needed for INCA (nbtr)157 CHARACTER(LEN=8), SAVE, ALLOCATABLE :: solsym(:)!--- Names from INCA (nbtr)148 REAL, SAVE, ALLOCATABLE :: tnat(:), & !--- Natural relative abundance of water isotope (niso) 149 alpha_ideal(:) !--- Ideal fractionning coefficient (for initial state) (niso) 150 INTEGER, SAVE, ALLOCATABLE :: conv_flg(:), & !--- Convection activation ; needed for INCA (nbtr) 151 pbl_flg(:) !--- Boundary layer activation ; needed for INCA (nbtr) 152 CHARACTER(LEN=8), SAVE, ALLOCATABLE :: solsym(:) !--- Names from INCA (nbtr) 158 153 LOGICAL, PARAMETER :: lOldCode = .TRUE. 159 154 … … 175 170 ! 05/94: F.Forget Modif special traceur 176 171 ! 02/02: M-A Filiberti Lecture de traceur.def 177 ! 01/22: D. Cugnet Nouveaux tracer.def et tracer_*.def + encapsulation (types tr et iso)172 ! 01/22: D. Cugnet Nouveaux tracer.def et tracer_*.def + encapsulation (types trac_type et isot_type) 178 173 ! 179 174 ! Objet: … … 212 207 TYPE(isot_type), POINTER :: iso 213 208 214 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnom_0(:), tnom_transp(:) 209 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnom_0(:), tnom_transp(:) !--- Tracer short name + transporting fluid name 215 210 CHARACTER(LEN=maxlen) :: tchaine 216 211 INTEGER :: ierr 217 LOGICAL :: lINCA218 212 219 213 CHARACTER(LEN=*), PARAMETER :: modname="infotrac_init" … … 238 232 !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION 239 233 msg1 = 'For type_trac = "'//TRIM(str(it))//'":' 240 SELECT CASE( type_trac)234 SELECT CASE(str(it)) 241 235 CASE('inca'); CALL msg(TRIM(msg1)//' coupling with INCA chemistry model, config_inca='//config_inca, modname) 242 236 CASE('inco'); CALL msg(TRIM(msg1)//' coupling jointly with INCA and CO2 cycle', modname) … … 254 248 !--- COHERENCE TEST BETWEEN "type_trac" AND PREPROCESSING KEYS 255 249 SELECT CASE(str(it)) 256 CASE('inca', 'inco')250 CASE('inca', 'inco') 257 251 #ifndef INCA 258 252 CALL abort_gcm(modname, 'You must add cpp key INCA and compile with INCA code', 1) … … 283 277 284 278 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 285 IF(lOldCode) THEN 279 IF(lOldCode) THEN !--- "type_trac" is a single keyword => no need to loop on its parsed version "str(:)" 286 280 !------------------------------------------------------------------------------------------------------------------------------ 287 281 !--- Determine nqtrue and (INCA only) nqo, nbtr … … 289 283 IF(ierr /= 0) CALL abort_gcm(modname, 'file "traceur.def" not found !', 1) 290 284 CALL msg('File "traceur.def" successfully opened.', modname) 291 lINCA = ANY(['inca','inco'] == type_trac) 292 293 IF(lINCA) THEN 285 286 IF(ANY(['inca','inco'] == type_trac)) THEN 294 287 #ifdef INCA 295 288 READ(90,*) nqo … … 299 292 nqtrue = nbtr + nqo 300 293 IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1) 301 CALL msg('nqo = '//TRIM(int2str(nqo)), modname)302 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname)303 CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname)304 CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname)305 CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname)306 294 ALLOCATE(hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA)) 307 295 ALLOCATE(vadv_inca(nqINCA), pbl_flg_inca(nqINCA)) 308 296 CALL init_transport(hadv_inca, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca) 309 ! DC passive CO2 tracer is at position 1: H2O was removed ; nqCO2/=0 in "inco" case only310 ALLOCATE(conv_flg(nbtr),pbl_flg(nbtr),solsym(nbtr))311 conv_flg = [( 1, ic=1, nqCO2),conv_flg_inca]312 pbl_flg = [( 1, ic=1, nqCO2), pbl_flg_inca]313 solsym = [('CO2 ', ic=1, nqCO2), solsym_inca]314 DEALLOCATE(conv_flg_inca, pbl_flg_inca)315 297 #endif 316 298 ELSE … … 337 319 END IF 338 320 #endif 339 CALL msg('237: iq='//TRIM(int2str(iq)), modname)340 321 READ(90,'(I2,X,I2,X,A)',IOSTAT=ierr) hadv(iq),vadv(iq),tchaine 341 WRITE(msg1,'("hadv(",i0,"), vadv(",i0,") = ",i0,", ",i0)')iq, iq, hadv(iq), vadv(iq)342 CALL msg(TRIM(msg1), modname)343 CALL msg('tchaine = "'//TRIM(tchaine)//'"', modname)344 CALL msg('infotrac 238: IOstatus='//TRIM(int2str(ierr)), modname)345 322 IF(ierr/=0) CALL abort_gcm('infotrac_init', 'Pb dans la lecture de traceur.def', 1) 346 323 jq = INDEX(tchaine(1:LEN_TRIM(tchaine)),' ') 347 324 CALL msg("Ancienne version de traceur.def: traceurs d'air uniquement", modname, iq==1 .AND. jq==0) 348 325 CALL msg("Nouvelle version de traceur.def", modname, iq==1 .AND. jq/=0) 326 CALL msg('iq, hadv, vadv, tchaine ='//TRIM(strStack(int2str([iq, hadv(iq), vadv(iq)])))//', '//TRIM(tchaine), modname) 349 327 IF(jq /= 0) THEN !--- Space in the string chain => new format 350 328 tnom_0 (iq) = tchaine(1:jq-1) … … 354 332 tnom_transp(iq) = 'air' 355 333 END IF 356 CALL msg( 'tnom_0(iq)=<'//TRIM(tnom_0(iq)) //'>', modname) 357 CALL msg('tnom_transp(iq)=<'//TRIM(tnom_transp(iq))//'>', modname) 358 END DO 359 #ifdef INCA 360 DEALLOCATE(solsym_inca) 361 #endif 362 334 END DO 363 335 CLOSE(90) 364 336 365 337 #ifndef INCA 366 CALL msg('Valeur de traceur.def :', modname)367 CALL msg('nombre total de traceurs '//TRIM(int2str(nqtrue)), modname)368 DO iq = 1, nqtrue369 CALL msg(strStack([int2str(hadv(iq)), int2str(vadv(iq)), tnom_0(iq), tnom_transp(iq)]), modname)370 END DO371 338 IF(planet_type /= 'earth') nqo = 0 !--- Same number of tracers in dynamics and physics 372 339 IF(planet_type == 'earth') nqo = COUNT(delPhase(tnom_0) == 'H2O') !--- for all planets except for Earth 373 nbtr = nqtrue - nqo 374 ALLOCATE(conv_flg(nbtr),pbl_flg(nbtr),solsym(nbtr)) 375 conv_flg(1:nbtr) = 1 !--- Convection activated for all tracers 376 pbl_flg(1:nbtr) = 1 !--- Boundary layer activated for all tracers 377 #endif 340 nbtr = nqtrue - nqo 341 #endif 342 343 CALL msg('RAW CONTENT OF "traceur.def" FILE:', modname) 344 IF(dispTable('iiss', ['hadv ', 'vadv ', 'name ', 'parent'], cat(tnom_0, tnom_transp), cat(hadv, vadv))) & 345 CALL abort_gcm(modname, "problem with the tracers table content", 1) 378 346 379 347 !--- SET FIELDS %name, %parent, %phase, %component 380 tracers(:)%name = tnom_0381 tracers(:)%parent = tnom_transp382 tracers(:)%phase = 'g'348 tracers(:)%name = old2newName(tnom_0) 349 tracers(:)%parent = old2newName(tnom_transp) 350 tracers(:)%phase = [( getPhase(tracers(iq)%name), iq=1, nqtrue )] 383 351 tracers(:)%component = type_trac 384 385 386 352 DO iq = 1, nqtrue 387 ip = strIdx([(addPhase('H2O',old_phases(ix:ix),''), ix=1, nphases)], strHead(tracers(iq)%name,'_',.TRUE.)) 388 IF(ip == 0) CYCLE 389 tracers(iq)%phase = known_phases(ip:ip) 390 tracers(iq)%component = 'lmdz' 391 END DO 392 IF(lINCA) tracers(1+nqo:nqCO2+nqo)%component = 'co2i' 353 IF(addPhase('H2O',tracers(iq)%phase) == tracers(iq)%name) tracers(iq)%component = 'lmdz' 354 END DO 355 IF(ANY(['inca','inco'] == type_trac)) tracers(1+nqo:nqCO2+nqo)%component = 'co2i' 393 356 CALL setGeneration(tracers) !--- SET FIELDS %iGeneration, %gen0Name 394 ! manque "type" 357 WHERE(tracers(:)%iGeneration == 2) tracers(:)%type = 'tag' !--- DEFAULT VALUE: "tracer" 358 359 !--- FINALIZE 360 DEALLOCATE(tnom_0, tnom_transp) 361 #ifdef INCA 362 DEALLOCATE(hadv_inca, vadv_inca, conv_flag_inca, pbl_flag_inca, solsym_inca) 363 #endif 395 364 396 365 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 400 369 IF(fType == 0) CALL abort_gcm(modname, 'Missing tracers file: "traceur.def", "tracer.def" or "tracer_<keyword>.def file.',1) 401 370 !--------------------------------------------------------------------------------------------------------------------------- 402 IF(fType == 1 ) THEN !=== FOUND AN OLD STYLE "traceur.def"371 IF(fType == 1 .AND. ANY(['inca','inco'] == type_trac)) THEN !=== FOUND OLD STYLE INCA "traceur.def" (single type_trac) 403 372 !--------------------------------------------------------------------------------------------------------------------------- 404 373 #ifdef INCA … … 409 378 nqtrue = nbtr + nqo !--- Total number of "true" tracers 410 379 IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1) 411 CALL msg('nqo = '//TRIM(int2str(nqo)), modname) 412 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) 413 CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname) 414 CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname) 415 CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname) 416 ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA)) 417 ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA), pbl_flg_inca(nqINCA)) 380 ALLOCATE(hadv(nqtrue), conv_flg(nbtr), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA)) 381 ALLOCATE(vadv(nqtrue), pbl_flg(nbtr), vadv_inca(nqINCA), pbl_flg_inca(nqINCA), solsym(nbtr)) 418 382 CALL init_transport(hadv_inca, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca) 419 ! DC passive CO2 tracer is at position 1: H2O was removed ; nqCO2/=0 in "inco" case only 420 421 conv_flg = [( 1 , k=1, nqCO2), conv_flg_inca] 422 pbl_flg = [( 1 , k=1, nqCO2), pbl_flg_inca] 423 solsym = [('CO2 ', k=1, nqCO2), solsym_inca] 424 DEALLOCATE(conv_flg_inca, pbl_flg_inca, solsym_inca) 383 !--- Passive CO2 tracer is at position 1 because: H2O has been removed ; nqCO2/=0 in "inco" case only 384 conv_flg(1:nbtr) = [(1, k=1, nqCO2), conv_flg_inca] 385 pbl_flg(1:nbtr) = [(1, k=1, nqCO2), pbl_flg_inca] 386 solsym (1:nbtr) = [('CO2 ', k=1, nqCO2), solsym_inca] 425 387 ALLOCATE(ttr(nqtrue)) 426 388 ttr(1:nqo+nqCO2) = tracers … … 433 395 lerr = getKey('hadv', had, ky=ttr(:)%keys); hadv(:) = [had, hadv_inca] 434 396 lerr = getKey('vadv', vad, ky=ttr(:)%keys); vadv(:) = [vad, vadv_inca] 435 DEALLOCATE(had, hadv_inca, vad, vadv_inca)436 397 CALL MOVE_ALLOC(FROM=ttr, TO=tracers) 437 398 CALL setGeneration(tracers) !--- SET FIELDS %iGeneration, %gen0Name 438 #else 439 nqo = COUNT(delPhase(tracers(:)%name) == 'H2O') !--- Number of water phases 399 DEALLOCATE(had, hadv_inca, vad, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca) 400 #endif 401 !--------------------------------------------------------------------------------------------------------------------------- 402 ELSE !=== FOUND NEW STYLE TRACERS CONFIGURATION FILE(S) 403 !--------------------------------------------------------------------------------------------------------------------------- 404 nqo = COUNT(delPhase(tracers(:)%name) == 'H2O' & 405 .AND. tracers(:)%component == 'lmdz') !--- Number of water phases 440 406 nqtrue = SIZE(tracers) !--- Total number of "true" tracers 441 nbtr = nqtrue - nqo !--- Number of tracers passed to phytrac 407 nbtr = nqtrue-COUNT(delPhase(tracers(:)%gen0Name) == 'H2O' & 408 .AND. tracers(:)%component == 'lmdz') !--- Number of tracers passed to phytrac 442 409 lerr = getKey('hadv', hadv, ky=tracers(:)%keys) 443 410 lerr = getKey('vadv', vadv, ky=tracers(:)%keys) 444 ALLOCATE(solsym(nbtr)) 445 conv_flg(1:nbtr)=1 !--- Convection activated for all tracers 446 pbl_flg(1:nbtr)=1 !--- Boundary layer activated for all tracers 447 #endif 448 !--------------------------------------------------------------------------------------------------------------------------- 449 ELSE !=== FOUND NEW STYLE TRACERS CONFIGURATION FILE(S) 450 !--------------------------------------------------------------------------------------------------------------------------- 451 nqo = COUNT(delPhase(tracers(:)%name) == 'H2O') !--- Number of water phases 452 nqtrue = SIZE(tracers) !--- Total number of "true" tracers 453 nbtr = nqtrue - nqo !--- Number of tracers passed to phytrac 454 lerr = getKey('hadv', hadv, ky=tracers(:)%keys) 455 lerr = getKey('vadv', vadv, ky=tracers(:)%keys) 456 ALLOCATE(solsym(nbtr)) 457 conv_flg(1:nbtr)=1 !--- Convection activated for all tracers 458 pbl_flg(1:nbtr)=1 !--- Boundary layer activated for all tracers 411 ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr)) 412 conv_flg(1:nbtr) = [(1, it=1, nbtr)] !--- Convection activated for all tracers 413 pbl_flg(1:nbtr) = [(1, it=1, nbtr)] !--- Boundary layer activated for all tracers 459 414 !--------------------------------------------------------------------------------------------------------------------------- 460 415 END IF … … 488 443 CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot))) 489 444 END IF 490 CALL msg('nqo = '//TRIM(int2str(nqo)), modname)491 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname)492 CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname)493 CALL msg('nqtot = '//TRIM(int2str(nqtot)), modname)494 445 495 446 !============================================================================================================================== … … 527 478 t1%iadv = iad 528 479 t1%isAdvected = iad >= 0 529 t1%isInPhysics= .not. (delPhase(t1%gen0Name) == 'H2O' .and. t1%component=='lmdz') !=== TO BE COMPLETED WITH OTHER EXCEPTIONS: CO2i, SURSATURATED CLOUDS... 480 t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' & 481 .OR. t1%component /= 'lmdz' !=== OTHER EXCEPTIONS TO BE ADDED: CO2i, SURSATURATED WATER CLOUD... 530 482 ttr(iq) = t1 531 483 532 484 !--- DEFINE THE HIGHER ORDER TRACERS, IF ANY 533 485 nm = 0 534 IF(iad == 20) nm = 3 535 IF(iad == 30) nm = 9 536 IF(nm == 0) CYCLE 486 IF(iad == 20) nm = 3 !--- 2nd order scheme 487 IF(iad == 30) nm = 9 !--- 3rd order scheme 488 IF(nm == 0) CYCLE !--- No higher moments 537 489 ttr(jq+1:jq+nm) = t1 538 490 ttr(jq+1:jq+nm)%name = [(TRIM(t1%name) //'-'//TRIM(suff(im)), im=1, nm) ] … … 549 501 CALL indexUpdate(tracers) 550 502 551 CALL msg('Information stored in infotrac :', modname)552 CALL msg('iadv name long_name :', modname)553 554 503 !=== TEST ADVECTION SCHEME 555 504 DO iq=1,nqtot ; t1 => tracers(iq); iad = t1%iadv … … 568 517 569 518 !--- ONLY VALID SCHEME NUMBER FOR WATER VAPOUR: iadv = 14 570 ll = t1%name /= addPhase('H2O','g') ; IF(lOldCode) ll = t1%name /= 'H2Ov'519 ll = t1%name /= addPhase('H2O','g') 571 520 IF(fmsg('WARNING ! iadv=14 is valid for water vapour only. Setting iadv=10 for "'//TRIM(t1%name)//'".', & 572 521 modname, iad == 14 .AND. ll)) t1%iadv = 10 … … 578 527 CALL infotrac_isoinit !--- SET FIELDS %type, %iso_iName, %iso_iZone, %iso_iPhase 579 528 CALL getKey_init(tracers, isotopes) 580 IF(isoSelect('H2O')) RETURN 581 iH2O = ixIso 529 IF(isoSelect('H2O')) RETURN !--- Select water isotopes ; finished if no water isotopes 530 iH2O = ixIso !--- Keep track of water family index 582 531 583 532 !--- Remove the isotopic tracers from the tracers list passed to phytrac 584 533 nbtr = nbtr -nqo* ntiso !--- ISOTOPIC TAGGING TRACERS ARE NOT PASSED TO THE PHYSICS 585 534 nqtottr = nqtot-nqo*(1+ntiso) !--- NO H2O-FAMILY TRACER IS PASSED TO THE PHYSICS 586 CALL msg('702: nbtr, ntiso='//strStack(int2str([nbtr, ntiso])), modname) 587 CALL msg('704: nqtottr, nqtot, nqo = '//strStack(int2str([nqtottr, nqtot, nqo])), modname) 588 ! Rq: nqtottr n'est pas forcement egal a nbtr dans le cas ou nmom/=0 589 IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers(:)%name) == 'H2O' .AND. tracers(:)%component=='lmdz') /= nqtottr) & 590 CALL abort_gcm('infotrac_init', 'pb dans le calcul de nqtottr', 1) 591 592 !--- Finalize : 593 DEALLOCATE(tnom_0, tnom_transp) 535 536 ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr)) 537 #ifndef INCA 538 conv_flg(1:nbtr) = 1 !--- Convection activated for all tracers 539 pbl_flg(1:nbtr) = 1 !--- Boundary layer activated for all tracers 540 #else 541 !--- Passive CO2 tracer is at position 1 because: H2O has been removed ; nqCO2/=0 in "inco" case only 542 conv_flg(1:nbtr) = [( 1, ic=1, nqCO2),conv_flg_inca] 543 pbl_flg(1:nbtr) = [( 1, ic=1, nqCO2), pbl_flg_inca] 544 solsym(1:nbtr) = [('CO2 ', ic=1, nqCO2), solsym_inca] 545 #endif 594 546 595 547 ELSE 596 548 597 549 CALL initIsotopes(tracers, isotopes) 598 nbIso = SIZE(isotopes); IF(nbIso==0) RETURN !--- No isotopes: finished. 599 600 !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE SPECIFIC TO WATER ISOTOPES 601 ! DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat, alpha_ideal) 602 CALL getKey_init(tracers, isotopes) 603 IF(isoSelect('H2O')) RETURN !--- Select water isotopes ; finished if no water isotopes 604 iH2O = ixIso !--- Keep track of water family index 605 IF(getKey('tnat' , tnat, isoName(1:niso))) CALL abort_gcm(modname, 'can''t read "tnat"', 1) 606 IF(getKey('alpha', alpha_ideal, isoName(1:niso))) CALL abort_gcm(modname, 'can''t read "alpha_ideal"', 1) 607 608 !=== ENSURE THE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES 609 DO ix = 1, nbIso 610 iso => isotopes(ix) 611 !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases 612 DO it = 1, iso%ntiso 613 np = SUM([(COUNT(tracers(:)%name == addPhase(iso%trac(it), iso%phase(ip:ip))), ip=1, iso%nphas)]) 614 IF(np == iso%nphas) CYCLE 615 WRITE(msg1,'("Found ",i0," phases for ",s," instead of ",i0)')np, iso%trac(it), iso%nphas 616 CALL abort_gcm(modname, msg1, 1) 550 nbIso = SIZE(isotopes) 551 nqtottr = nqtot - COUNT(tracers%gen0Name == 'H2O' .AND. tracers%component == 'lmdz') 552 IF(nbIso/=0) THEN !--- ISOTOPES FOUND 553 554 !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE SPECIFIC TO WATER ISOTOPES 555 ! DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat, alpha_ideal) 556 CALL getKey_init(tracers, isotopes) 557 IF(isoSelect('H2O')) RETURN !--- Select water isotopes ; finished if no water isotopes 558 iH2O = ixIso !--- Keep track of water family index 559 IF(getKey('tnat' , tnat, isoName(1:niso))) CALL abort_gcm(modname, 'can''t read "tnat"', 1) 560 IF(getKey('alpha', alpha_ideal, isoName(1:niso))) CALL abort_gcm(modname, 'can''t read "alpha_ideal"', 1) 561 562 !=== MAKE SURE THE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES 563 DO ix = 1, nbIso 564 iso => isotopes(ix) 565 !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases 566 DO it = 1, iso%ntiso 567 np = SUM([(COUNT(tracers(:)%name == addPhase(iso%trac(it), iso%phase(ip:ip))), ip=1, iso%nphas)]) 568 IF(np == iso%nphas) CYCLE 569 WRITE(msg1,'("Found ",i0," phases for ",a," instead of ",i0)')np, TRIM(iso%trac(it)), iso%nphas 570 CALL abort_gcm(modname, msg1, 1) 571 END DO 572 DO it = 1, iso%niso 573 nz = SUM([(COUNT(iso%trac == TRIM(iso%trac(it))//'_'//iso%zone(iz)), iz=1, iso%nzone)]) 574 IF(nz == iso%nzone) CYCLE 575 WRITE(msg1,'("Found ",i0," tagging zones for ",a," instead of ",i0)')nz, TRIM(iso%trac(it)), iso%nzone 576 CALL abort_gcm(modname, msg1, 1) 577 END DO 617 578 END DO 618 DO it = 1, iso%niso 619 nz = SUM([(COUNT(iso%trac == iso%trac(it)//'_'//iso%zone(iz)), iz=1, iso%nzone)]) 620 IF(nz == iso%nzone) CYCLE 621 WRITE(msg1,'("Found ",i0," tagging zones for ",s," instead of ",i0)')nz, iso%trac(it), iso%nzone 622 CALL abort_gcm(modname, msg1, 1) 623 END DO 624 END DO 625 nqtottr = COUNT(tracers%iso_iName == 0) 579 END IF 626 580 627 581 END IF 628 582 629 !=== DISPLAY THE RESULTING LIST 630 t => tracers 631 CALL msg('Information stored in infotrac :') 632 IF(dispTable('isssssssssiiiiiiiii', & 633 ['iq ', 'name ', 'longN. ', 'gen0N. ', 'parent ', 'type ', 'phase ', 'compon. ', 'isAdv. ', 'isPhy. '& 634 ,'iadv ', 'iGen. ', 'iqPar. ', 'nqDes. ', 'nqChil. ', 'iso_iG. ', 'iso_iN. ', 'iso_iZ. ', 'iso_iP. '], & 635 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, & 636 t%component, bool2str(t%isAdvected), bool2str(t%isInPhysics)), & 637 cat([(iq, iq=1, nqtot)], t%iadv, t%iGeneration, t%iqParent, t%nqDescen, & 638 t%nqChilds, t%iso_iGroup, t%iso_iName, t%iso_iZone, t%iso_iPhase))) & 639 CALL abort_gcm(modname, "problem with the tracers table content", 1) 583 !--- Note: nqtottr can differ from nbtr when nmom/=0 584 ! IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers%name) == 'H2O' .AND. tracers%component == 'lmdz') /= nqtottr) & 585 ! CALL abort_gcm('infotrac_init', 'pb dans le calcul de nqtottr', 1) 640 586 641 587 !--- Some aliases to be removed later 642 ntraciso => isotope%ntiso643 ntraceurs_zone => isotope%nzone588 ntraciso => ntiso 589 ntraceurs_zone => nzone 644 590 qperemin = min_qParent 645 591 masseqmin = min_qMass 646 592 ratiomin = min_ratio 593 iqiso => iqTraPha 594 index_trac => itZonIso 595 596 !=== DISPLAY THE RESULTS 597 CALL msg('nqo = '//TRIM(int2str(nqo)), modname) 598 CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) 599 CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname) 600 CALL msg('nqtot = '//TRIM(int2str(nqtot)), modname) 601 CALL msg('niso = '//TRIM(int2str(niso)), modname) 602 CALL msg('ntiso = '//TRIM(int2str(ntiso)), modname) 603 #ifdef INCA 604 CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname) 605 CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname) 606 #endif 607 t => tracers 608 CALL msg('Information stored in infotrac :', modname) 609 IF(dispTable('isssssssssiiiiiiiii', & 610 ['iq ', 'name ', 'lName ', 'gen0N ', 'parent', 'type ', 'phase ', 'compon', 'isAdv ', 'isPhy ', & 611 'iadv ', 'iGen ', 'iqPar ', 'nqDes ', 'nqChld', 'iGroup', 'iName ', 'iZone ', 'iPhase'], & 612 cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isAdvected), & 613 bool2str(t%isInPhysics)),& 614 cat([(iq, iq=1, nqtot)], t%iadv, t%iGeneration, t%iqParent, t%nqDescen, t%nqChilds, t%iso_iGroup, & 615 t%iso_iName, t%iso_iZone, t%iso_iPhase), sub=modname)) & 616 CALL abort_gcm(modname, "problem with the tracers table content", 1) 617 IF(niso > 0) THEN 618 CALL msg('Where, for isotopes family "'//TRIM(isotope%parent)//'":', modname) 619 CALL msg(' isoKeys = '//strStack(isoKeys%name), modname) 620 CALL msg(' isoName = '//strStack(isoName), modname) 621 CALL msg(' isoZone = '//strStack(isoZone), modname) 622 CALL msg(' isoPhas = '//TRIM(isoPhas), modname) 623 ELSE 624 CALL msg('No isotopes identified.', modname) 625 END IF 647 626 CALL msg('end', modname) 648 627 … … 654 633 !--- Purpose: Set fields %iqParent, %nqChilds, %iGeneration, %iqDescen, %nqDescen (old method) 655 634 USE strings_mod, ONLY: strIdx 656 INTEGER :: iq, ipere, ifils635 INTEGER :: iq, jq, ipere, ifils 657 636 INTEGER, ALLOCATABLE :: iqfils(:,:) 658 637 CHARACTER(LEN=maxlen) :: msg1, modname='infotrac_init' … … 661 640 !=== SET FIELDS %iqParent, %nqChilds 662 641 ALLOCATE(iqfils(nqtot,nqtot)); iqfils(:,:) = 0 642 tracers(:)%nqChilds = 0 643 tracers(:)%iqParent = 0 663 644 664 645 DO iq = 1, nqtot … … 684 665 CALL msg('iqChilds = '//strStack(int2str(PACK(iqfils,MASK=.TRUE.))),modname) 685 666 686 687 667 !=== SET FIELDS %iGeneration, %iqDescen, %nqDescen 688 668 tracers(:)%iGeneration = 0 669 tracers(:)%nqDescen = 0 689 670 DO iq = 1, nqtot 690 671 ifils = iq … … 703 684 END DO 704 685 686 !=== SET FIELD %gen0Name 687 DO iq = 1, nqtot 688 jq=iq; DO WHILE(tracers(jq)%iGeneration > 0); jq=tracers(jq)%iqParent; END DO 689 tracers(iq)%gen0Name = tracers(jq)%name 690 END DO 691 705 692 CALL msg('nqDescen = '//TRIM(strStack(int2str(tracers(:)%nqDescen))), modname) 706 693 CALL msg('nqDescen_tot = ' //TRIM(int2str(SUM(tracers(:)%nqDescen))), modname) 707 CALL msg('iqChilds = '//strStack(int2str(PACK(iqfils, MASK=.TRUE.))), modname) 708 694 CALL msg('iqDescen = '//strStack(int2str(PACK(iqfils, MASK=.TRUE.))), modname) 709 695 710 696 END SUBROUTINE infotrac_setHeredity … … 719 705 USE ioipsl_getincom 720 706 #endif 707 USE readTracFiles_mod, ONLY: tnom_iso => newH2OIso 721 708 IMPLICIT NONE 722 CHARACTER(LEN=3) :: tnom_iso(niso_possibles) 723 INTEGER, ALLOCATABLE :: nb_iso(:,:), nb_traciso(:,:), nb_isoind(:) 724 INTEGER :: ii, ip, iq, it, iz, ixt, nzone_prec 709 INTEGER, ALLOCATABLE :: nb_iso(:), nb_tiso(:), nb_zone(:), ix(:) 710 INTEGER :: ii, ip, iq, it, iz, ixt 725 711 TYPE(isot_type), POINTER :: i 726 TYPE(trac_type), POINTER :: t(:) 727 CHARACTER(LEN=maxlen) :: tnom_trac 712 TYPE(trac_type), POINTER :: t(:), t1 713 CHARACTER(LEN=maxlen) :: tnom_trac, modname, t0 728 714 CHARACTER(LEN=maxlen), ALLOCATABLE :: str(:) 729 715 LOGICAL, DIMENSION(:), ALLOCATABLE :: mask 716 REAL, ALLOCATABLE :: tnat0(:), alpha_ideal0(:) 730 717 INCLUDE "iniprint.h" 731 718 732 tnom_iso = ['eau', 'HDO', 'O18', 'O17', 'HTO'] 733 ALLOCATE(nb_iso (niso_possibles,nqo)) 734 ALLOCATE(nb_traciso (niso_possibles,nqo)) 735 ALLOCATE(use_iso (niso_possibles)) 736 ALLOCATE(indnum_fn_num(niso_possibles)) 737 ALLOCATE(iso_indnum(nqtot)) 738 ALLOCATE(nb_isoind(nqo)) 739 740 iso_indnum (:) = 0 741 use_iso (:) = .FALSE. 742 indnum_fn_num(:) = 0 743 nb_iso (:,:) = 0 744 nb_traciso (:,:) = 0 745 nb_isoind (:) = 0 746 747 DO iq=1, nqtot 748 IF(delPhase(tracers(iq)%name) == 'H2O' .OR. .NOT.tracers(iq)%isAdvected) CYCLE 749 outer:DO ip = 1, nqo 750 DO ixt= 1,niso_possibles 751 tnom_trac = 'H2O'//old_phases(ip:ip)//'_'//TRIM(tnom_iso(ixt)) 752 IF (tracers(iq)%name == tnom_trac) THEN 753 nb_iso(ixt,ip) = nb_iso(ixt,ip)+1 754 nb_isoind (ip) = nb_isoind (ip)+1 755 tracers(iq)%type = 'tracer' 756 tracers(iq)%iso_iGroup = 1 757 tracers(iq)%iso_iName = ixt 758 iso_indnum(iq) = nb_isoind(ip) 759 indnum_fn_num(ixt) = iso_indnum(iq) 760 tracers(iq)%iso_iPhase = ip 761 EXIT outer 762 ELSE IF(tracers(iq)%iqParent> 0) THEN 763 IF(tracers(tracers(iq)%iqParent)%name == tnom_trac) THEN 764 nb_traciso(ixt,ip) = nb_traciso(ixt,ip)+1 765 iso_indnum(iq) = indnum_fn_num(ixt) 766 tracers(iq)%type = 'tag' 767 tracers(iq)%iso_iGroup = 1 768 tracers(iq)%iso_iName = ixt 769 tracers(iq)%iso_iZone = nb_traciso(ixt,ip) 770 tracers(iq)%iso_iPhase = ip 771 EXIT outer 772 END IF 773 END IF 774 END DO 775 END DO outer 776 END DO 777 778 niso = 0; nzone_prec = nb_traciso(1,1) 779 DO ixt = 1, niso_possibles 780 IF(nb_iso(ixt,1) == 0) CYCLE 781 IF(nb_iso(ixt,1) /= 1) CALL abort_gcm('infotrac_init', 'Isotopes are not well defined in traceur.def', 1) 782 783 ! on verifie que toutes les phases ont le meme nombre d'isotopes 784 IF(ANY(nb_iso(ixt,:) /= 1)) CALL abort_gcm('infotrac_init', 'Phases must have same number of isotopes', 1) 785 786 niso = niso+1 787 use_iso(ixt) = .TRUE. 788 nzone = nb_traciso(ixt,1) 789 790 ! on verifie que toutes les phases ont le meme nombre de traceurs d'isotopes 791 IF(ANY(nb_traciso(ixt,2:nqo) /= nzone)) CALL abort_gcm('infotrac_init','Phases must have same number of tracers',1) 792 793 ! on verifie que tous les isotopes ont le meme nombre de traceurs d'isotopes 794 IF(nzone /= nzone_prec) CALL abort_gcm('infotrac_init','Isotope tracers are not well defined in traceur.def',1) 795 nzone_prec = nzone 796 END DO 797 798 ! dimensions et flags isotopiques: 799 ntiso = niso*(nzone+1) 800 ok_isotopes = niso > 0 801 ok_isotrac = nzone > 0 802 803 IF(ok_isotopes) THEN 804 ok_iso_verif = .FALSE.; CALL getin('ok_iso_verif', ok_iso_verif) 805 ok_init_iso = .FALSE.; CALL getin('ok_init_iso', ok_init_iso) 806 END IF 807 tnat = [1.0, 155.76e-6, 2005.2e-6, 0.004/100., 0.0] 808 alpha_ideal = [1.0, 1.01, 1.006, 1.003, 1.0] 809 ! END IF 810 811 ! remplissage du tableau iqiso(ntiso,phase) 812 ALLOCATE(iqiso(ntiso,nqo)) 813 iqiso(:,:)=0 814 DO iq = 1, nqtot 815 IF(tracers(iq)%iso_iName <= 0) CYCLE 816 ixt = iso_indnum(iq) + tracers(iq)%iso_iZone*niso 817 iqiso(ixt, tracers(iq)%iso_iPhase) = iq 818 END DO 819 820 ! remplissage du tableau index_trac(nzone,niso) 821 ALLOCATE(index_trac(nzone, niso)) 822 IF(ok_isotrac) then 823 DO ii = 1, niso; index_trac(:, ii) = ii + niso*[(iz, iz=1, nzone)]; END DO 824 ELSE 825 index_trac(:,:)=0.0 826 END IF 827 719 modname = 'infotrac_isoinit' 720 tnat0 = [ 1.0 , 155.76e-6, 2005.2e-6, 0.004/100., 0.0 ] !--- Same length as tnom_iso 721 alpha_ideal0= [ 1.0 , 1.01, 1.006, 1.003, 1.0 ] !--- Same length as tnom_iso 828 722 ALLOCATE(isotopes(1)) !--- Only water 829 nbIso = 1723 nbIso = SIZE(isotopes) 830 724 t => tracers 831 725 i => isotopes(1) 832 726 i%parent = 'H2O' 833 727 834 !--- Isotopes names list (embedded in the "keys" field) 835 i%niso = niso 836 ALLOCATE(i%keys(i%niso)) 837 mask = t%type=='tracer' .AND. delPhase(t%gen0Name)=='H2O' .AND. t%phase == 'g' .AND. t%iGeneration==1 838 str = strTail(PACK(delPhase(t%name), MASK=mask), '_') 839 CALL strReduce(str) 840 i%keys(:)%name = str 841 842 !--- Full isotopes list, with isotopes tagging tracers (if any) following the previous list 843 i%ntiso = ntiso 844 ALLOCATE(i%trac(i%ntiso)) 845 mask = t%type=='tag' .AND. delPhase(t%gen0Name)=='H2O' .AND. t%phase == 'g' .AND. t%iGeneration==2 728 !--- Effective isotopes names list (embedded in the "keys" field) 729 mask = t%type=='tracer' .AND. t%gen0Name==addPhase('H2O', 'g') .AND. t%iGeneration==1 846 730 str = PACK(delPhase(t%name), MASK=mask) 847 731 CALL strReduce(str) 732 i%niso = SIZE(str) 733 ALLOCATE(i%keys(i%niso)) 734 i%keys(:)%name = str 735 736 !--- Check whether found isotopes are known 737 mask = [(ALL(tnom_iso /= str(ii)), ii=1, i%niso)] 738 IF(ANY(mask)) CALL abort_gcm(modname, 'The following isotopes are unknown: '//strStack(PACK(str, MASK=mask)), 1) 739 740 !--- Full isotopes list, with isotopes tagging tracers (if any) following the previous list 741 mask = t%type=='tag' .AND. t%gen0Name==addPhase('H2O', 'g') .AND. t%iGeneration==2 742 str = PACK(delPhase(t%name), MASK=mask) 743 i%ntiso = i%niso + SIZE(str) 744 ALLOCATE(i%trac(i%ntiso)) 848 745 i%trac(:) = [i%keys(:)%name, str] 849 746 850 !--- Tagging zones names list 851 i%nzone = nzone 747 !--- Effective tagging zones names list 852 748 i%zone = strTail(str, '_', .TRUE.) 749 CALL strReduce(i%zone) 750 i%nzone = SIZE(i%zone) 751 IF(i%ntiso /= i%niso*(i%nzone+1)) CALL abort_gcm(modname, 'Error in "ntiso" calculation', 1) 853 752 854 753 !--- Effective phases list 855 i%nphas = nqo856 754 i%phase = '' 857 DO ip=1,nphases; IF(strIdx(t%name, addPhase('H2O',old_phases(ip:ip),''))/=0) i%phase=TRIM(i%phase)//known_phases(ip:ip); END DO 858 859 !--- Table: index in "qx" of an isotope, knowing its indices "it","ip" in "isotope%iName,%iPhase" 860 i%iTraPha = RESHAPE([((strIdx(t%name, TRIM(addPhase('H2O', new2oldPhase(i%phase(ip:ip)), ''))//'_'//TRIM(i%trac(it))), & 861 it=1,i%ntiso), ip=1,i%nphas)], [i%ntiso,i%nphas]) 755 DO ip=1,nphases; IF(strIdx(t%name, addPhase('H2O', ip))/=0) i%phase=TRIM(i%phase)//known_phases(ip:ip); END DO 756 i%nphas = LEN_TRIM(i%phase) 757 758 !--- Indexes related to isotopes 759 DO iq = 1, nqtot 760 t1 => tracers(iq) 761 t0 = t1%gen0Name 762 IF(t1%iGeneration==0 .OR. .NOT.t1%isAdvected .OR. delPhase(t0)/='H2O') CYCLE 763 t1%iso_iGroup = 1 764 t1%iso_iPhase = INDEX(i%phase, getPhase(t0)) 765 t1%iso_iZone = strIdx(i%zone, strTail(t1%name, '_')) 766 IF(t1%iso_iZone /= 0) t1%iso_iName = strIdx(i%keys(:)%name, delPhase(t1%parent)) 767 IF(t1%iso_iZone == 0) t1%iso_iName = strIdx(i%keys(:)%name, delPhase(t1%name )) 768 END DO 769 770 niso_possibles = SIZE(tnom_iso) 771 ! ix = strIdx(tnom_iso, i%trac) 772 ! tnat = tnat0 (PACK(ix, MASK=ix/=0)) 773 ! alpha_ideal = alpha_ideal0(PACK(ix, MASK=ix/=0)) 774 tnat = tnat0 775 alpha_ideal = alpha_ideal0 776 777 !--- Tests 778 nb_iso = [(COUNT(t%iso_iPhase == ip .AND. t%iGeneration == 1), ip=1, i%nphas)] 779 nb_tiso = [(COUNT(t%iso_iPhase == ip .AND. t%iGeneration == 2), ip=1, i%nphas)] 780 nb_zone = [(COUNT(t%iso_iZone == iz), iz=1, i%nzone)] 781 IF(ANY(nb_iso (:) /= nb_iso (1))) CALL abort_gcm(modname, 'Phases must have same number of isotopes', 1) 782 IF(ANY(nb_tiso(:) /= nb_tiso(1))) CALL abort_gcm(modname, 'Phases must have same number of tagging tracers', 1) 783 IF(ANY(nb_zone(:) /= nb_zone(1))) CALL abort_gcm(modname, 'Isotopes must have the same number of tagging tracers', 1) 784 785 !--- Isotopic checking routines activation flag 786 i%check = .FALSE.; IF(i%niso > 0) CALL getin('ok_iso_verif', i%check) 787 788 !--- Table: index in "qx(:)" of an isotope, knowing its indices "it","ip" in "isotope%iName,%iPhase" 789 i%iqTraPha = RESHAPE([((strIdx(t%name, TRIM(addPhase(i%trac(it),ip,i%phase))),it=1,i%ntiso),ip=1,i%nphas)],[i%ntiso,i%nphas]) 862 790 863 791 !--- Table: index in "isotope%tracs(:)%name" of an isotopic tagging tracer, knowing its indices "iz","ip" in "isotope%iZone,%iName" 864 i%iZonIso = RESHAPE([((strIdx(i%trac,TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))),iz=1,i%nzone),it=1,i%niso )],[i%nzone,i%niso ]) 865 DO it=1,ntiso 866 WRITE(lunout,'(a,i0,a)')TRIM('infotrac_init')//': iqiso (',it,',:) = '//strStack(int2str(iqiso(it,:))) 867 WRITE(lunout,'(a,i0,a)')TRIM('infotrac_init')//': iTraPha(',it,',:) = '//strStack(int2str(i%iTraPha(it,:))) 868 END DO 869 DO iz=1,nzone 870 WRITE(lunout,'(a,i0,a)')TRIM('infotrac_init')//': index_trac(',iz,',:) = '//strStack(int2str(index_trac(iz,:))) 871 WRITE(lunout,'(a,i0,a)')TRIM('infotrac_init')//': iZonIso (',iz,',:) = '//strStack(int2str(i%iZonIso(iz,:))) 872 END DO 873 874 ! Finalize : 792 i%itZonIso = RESHAPE([((strIdx(i%trac,TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))),iz=1,i%nzone),it=1,i%niso )],[i%nzone,i%niso]) 793 794 DO it=1,i%ntiso; CALL msg('iqTraPha('//TRIM(int2str(it))//',:) = '//strStack(int2str(i%iqTraPha(it,:))), modname); END DO 795 DO iz=1,i%nzone; CALL msg('itZonIso('//TRIM(int2str(iz))//',:) = '//strStack(int2str(i%itZonIso(iz,:))), modname); END DO 796 797 !--- Isotopic quantities (to be removed soon) 798 ok_isotopes = i%niso > 0 799 ok_isotrac = i%nzone > 0 800 ok_iso_verif = i%check 801 niso_possibles = SIZE(tnom_iso) 802 iso_num = [(strIdx(tnom_iso(:), strHead(delPhase(tracers(iq)%name), '_')), iq=1, nqtot)] 803 iso_indnum = [(strIdx(i%keys(:)%name, strHead(delPhase(tracers(iq)%name), '_')), iq=1, nqtot)] 804 indnum_fn_num = [(strIdx(i%keys(:)%name, tnom_iso(ixt)), ixt=1, niso_possibles)] 805 use_iso = indnum_fn_num /= 0 !--- .TRUE. for the effectively used isotopes of the possible isotopes list 806 807 !--- Finalize : 875 808 DEALLOCATE(nb_iso) 876 809 … … 903 836 lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose 904 837 lerr = .FALSE. 905 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK838 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK 906 839 lerr = iIso<=0 .OR. iIso>nbIso 907 840 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '//TRIM(int2str(nbIso))//'"',& 908 841 ll=lerr .AND. lV) 909 842 IF(lerr) RETURN 910 ixIso = iIso !--- Update currently selected family index911 isotope => isotopes(ixIso)!--- Select corresponding component912 isoKeys => isotope%keys; niso =isotope%niso913 isoName => isotope%trac; ntiso =isotope%ntiso914 isoZone => isotope%zone; nzone =isotope%nzone915 isoPhas => isotope%phase; nphas =isotope%nphas916 i ZonIso => isotope%iZonIso; isoCheck =isotope%check917 i TraPha => isotope%iTraPha843 ixIso = iIso !--- Update currently selected family index 844 isotope => isotopes(ixIso) !--- Select corresponding component 845 isoKeys => isotope%keys; niso => isotope%niso 846 isoName => isotope%trac; ntiso => isotope%ntiso 847 isoZone => isotope%zone; nzone => isotope%nzone 848 isoPhas => isotope%phase; nphas => isotope%nphas 849 itZonIso => isotope%itZonIso; isoCheck => isotope%check 850 iqTraPha => isotope%iqTraPha 918 851 END FUNCTION isoSelectByIndex 919 852 !============================================================================================================================== -
LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90
r4063 r4120 7 7 !------------------------------------------------------------------------------- 8 8 USE parallel_lmdz 9 USE strings_mod, ONLY: maxlen 10 USE infotrac, ONLY: nqtot, tracers, iqiso, iso_indnum, tnat, alpha_ideal, ok_isotopes 11 USE netcdf, ONLY: NF90_OPEN, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, & 12 NF90_NOWRITE, NF90_CLOSE, NF90_INQUIRE_VARIABLE, NF90_GET_VAR, NF90_NoErr 9 USE infotrac, ONLY: nqtot, tracers, niso, iqiso, iso_indnum, iso_num, tnat, alpha_ideal, ok_isotopes, iH2O 10 USE strings_mod, ONLY: maxlen, msg, strStack, real2str 11 USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, & 12 NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE, NF90_NoErr 13 USE readTracFiles_mod, ONLY: new2oldName 13 14 USE control_mod, ONLY: planet_type 14 15 USE assert_eq_m, ONLY: assert_eq 15 16 USE comvert_mod, ONLY: pa,preff 16 USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, & 17 omeg, rad 17 USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad 18 18 USE logic_mod, ONLY: fxyhypb, ysinus 19 19 USE serre_mod, ONLY: clon, clat, grossismx, grossismy 20 USE temps_mod, ONLY: annee_ref,day_ref,itau_dyn, & 21 start_time,day_ini,hour_ini 20 USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time 22 21 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 23 22 24 23 IMPLICIT NONE 25 24 include "dimensions.h" … … 40 39 !=============================================================================== 41 40 ! Local variables: 42 CHARACTER(LEN=maxlen) :: m sg, var, modname41 CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar 43 42 INTEGER, PARAMETER :: length=100 44 43 INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase … … 58 57 !!! .... while keeping everything OK for LMDZ EARTH 59 58 IF(planet_type=="generic") THEN 60 WRITE(lunout,*)'NOTE NOTE NOTE : Planeto-like start files'59 CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname) 61 60 idecal = 4 62 61 annee_ref = 2000 63 62 ELSE 64 WRITE(lunout,*)'NOTE NOTE NOTE : Earth-like start files'63 CALL msg('NOTE NOTE NOTE : Earth-like start files', modname) 65 64 idecal = 5 66 65 annee_ref = tab_cntrl(5) … … 106 105 107 106 !------------------------------------------------------------------------------- 108 WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa107 CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname) 109 108 CALL check_dim(im,iim,'im','im') 110 109 CALL check_dim(jm,jjm,'jm','jm') … … 120 119 var="temps" 121 120 IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN 122 WRITE(lunout,*)TRIM(modname)//": missing field <temps>"123 WRITE(lunout,*)TRIM(modname)//": trying with <Time>";var="Time"121 CALL msg('missing field <temps> ; trying with <Time>', modname) 122 var="Time" 124 123 CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var) 125 124 END IF … … 153 152 ALLOCATE(q_glo(ip1jmp1,llm)) 154 153 DO iq=1,nqtot 155 var=TRIM(tracers(iq)%name) 154 var = tracers(iq)%name 155 oldVar = new2oldName(var) 156 !-------------------------------------------------------------------------------------------------------------------------- 157 IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr) THEN !=== REGULAR CASE 158 CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:) 159 !-------------------------------------------------------------------------------------------------------------------------- 160 ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN !=== OLD NAME 161 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname) 162 CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:) 163 !-------------------------------------------------------------------------------------------------------------------------- 156 164 #ifdef INCA 157 IF (var .eq. "O3" ) THEN 158 IF(NF90_INQ_VARID(fID,var,vID) == NF90_NoErr) THEN 159 CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE 160 ELSE 161 WRITE(lunout,*) 'Tracer O3 is missing - it is initialized to OX' 162 IF(NF90_INQ_VARID(fID,"OX",vID) == NF90_NoErr) THEN 163 CALL get_var2("OX",q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE 164 ENDIF 165 ENDIF 166 ENDIF 165 ELSE IF(NF90_INQ_VARID(fID, 'OX', vID) == NF90_NoErr .AND. var == 'O3') THEN !=== INCA: OX INSTEAD OF O3 166 CALL msg('Tracer <O3> is missing => initialized to <OX>', modname) 167 CALL get_var2( 'OX' , q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:) 168 !-------------------------------------------------------------------------------------------------------------------------- 167 169 #endif 168 IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN 169 CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE 170 ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN !=== WATER ISOTOPES 171 ! iName = tracers(iq)%iso_iName ! (next commit) 172 iName = iso_num(iq) 173 iPhase = tracers(iq)%iso_iPhase 174 iqParent = tracers(iq)%iqParent 175 IF(tracers(iq)%iso_iZone == 0) THEN 176 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname) 177 q(ijb_u:ije_u,:,iq)= q(ijb_u:ije_u,:,iqParent)*tnat(iName)*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.) 178 ELSE 179 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to its parent isotope concentration.', modname) 180 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqiso(iso_indnum(iq),iPhase)) 181 END IF 182 !-------------------------------------------------------------------------------------------------------------------------- 183 ELSE !=== MISSING: SET TO 0 184 CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to zero', modname) 185 q(ijb_u:ije_u,:,iq)=0. 186 !-------------------------------------------------------------------------------------------------------------------------- 170 187 END IF 171 WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"172 WRITE(lunout,*)" It is hence initialized to zero"173 q(ijb_u:ije_u,:,iq)=0.174 !--- CRisi: for isotops, theoretical initialization using very simplified175 ! Rayleigh distillation las.176 iName = tracers(iq)%iso_iName177 IF(.NOT.ok_isotopes .OR. iName <= 0) CYCLE178 iZone = tracers(iq)%iso_iZone179 iPhase= tracers(iq)%iso_iPhase180 iqParent = tracers(iq)%iqParent181 IF(iZone==0) q(:,:,iq) = q(:,:,iqParent)*tnat(iName) &182 & *(q(:,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.)183 IF(iZone==1) q(:,:,iq) = q(:,:,iqiso(iso_indnum(iq),iPhase))184 188 END DO 185 189 DEALLOCATE(q_glo) … … 199 203 s1='value of '//TRIM(str1)//' =' 200 204 s2=' read in starting file differs from parametrized '//TRIM(str2)//' =' 201 WRITE(m sg,'(10x,a,i4,2x,a,i4)'),s1,n1,s2,n2202 CALL ABORT_gcm(TRIM(modname),TRIM(m sg),1)205 WRITE(mesg,'(10x,a,i4,2x,a,i4)')TRIM(ADJUSTL(s1)),n1,TRIM(ADJUSTL(s2)),n2 206 CALL ABORT_gcm(TRIM(modname),TRIM(mesg),1) 203 207 END IF 204 208 END SUBROUTINE check_dim … … 263 267 IF(ierr==NF90_NoERR) RETURN 264 268 SELECT CASE(typ) 265 CASE('inq'); m sg="Field <"//TRIM(nam)//"> is missing"266 CASE('get'); m sg="Reading failed for <"//TRIM(nam)//">"267 CASE('open'); m sg="File opening failed for <"//TRIM(nam)//">"268 CASE('close'); m sg="File closing failed for <"//TRIM(nam)//">"269 CASE('inq'); mesg="Field <"//TRIM(nam)//"> is missing" 270 CASE('get'); mesg="Reading failed for <"//TRIM(nam)//">" 271 CASE('open'); mesg="File opening failed for <"//TRIM(nam)//">" 272 CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">" 269 273 END SELECT 270 CALL ABORT_gcm(TRIM(modname),TRIM(m sg),ierr)274 CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr) 271 275 END SUBROUTINE err 272 276 -
LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.F90
r4056 r4120 6 6 USE filtreg_mod, ONLY: inifilr 7 7 USE infotrac, ONLY: nqtot, niso_possibles, ok_isotopes, ok_iso_verif, tnat, alpha_ideal, & 8 iqiso, tracers, iso_indnum 8 iqiso, tracers, iso_indnum, iso_num 9 9 USE control_mod, ONLY: day_step,planet_type 10 10 use exner_hyb_m, only: exner_hyb … … 23 23 USE temps_mod, ONLY: annee_ref, day_ini, day_ref 24 24 USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 25 USE readTracFiles_mod, ONLY: addPhase 25 26 26 27 ! Author: Frederic Hourdin original: 15/01/93 … … 66 67 real tetastrat ! potential temperature in the stratosphere, in K 67 68 real tetajl(jjp1,llm) 68 INTEGER i,j,l,lsup,ij, iq, iName, i Zone, iPhase, iqParent69 INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent 69 70 70 71 REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T … … 280 281 do iq=1,nqtot 281 282 q(ijb_u:ije_u,:,iq)=0. 282 ! IF(tracers(iq)%name == 'H2O'//phases_sep//'g') q(ijb_u:ije_u,:,iq)=1.e-10 283 ! IF(tracers(iq)%name == 'H2O'//phases_sep//'l') q(ijb_u:ije_u,:,iq)=1.e-15 284 IF(tracers(iq)%name == 'H2Ov') q(ijb_u:ije_u,:,iq)=1.e-10 285 IF(tracers(iq)%name == 'H2Ol') q(ijb_u:ije_u,:,iq)=1.e-15 283 IF(tracers(iq)%name == addPhase('H2O', 'g')) q(ijb_u:ije_u,:,iq)=1.e-10 284 IF(tracers(iq)%name == addPhase('H2O', 'l')) q(ijb_u:ije_u,:,iq)=1.e-15 286 285 287 286 ! CRisi: init des isotopes 288 287 ! distill de Rayleigh très simplifiée 289 iName = tracers(iq)%iso_iName 288 ! iName = tracers(iq)%iso_iName ! (next commit) 289 iName = iso_num(iq) 290 290 if (.NOT.ok_isotopes .OR. iName <= 0) CYCLE 291 iZone = tracers(iq)%iso_iZone292 291 iPhase = tracers(iq)%iso_iPhase 293 292 iqParent = tracers(iq)%iqParent 294 if (iZone == 0) q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat(iName) & 295 *(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1) 296 if (iZone == 1) q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqiso(iso_indnum(iq),iPhase)) 293 IF(tracers(iq)%iso_iZone == 0) THEN 294 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat(iName) & 295 *(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal(iName)-1.) 296 ELSE 297 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqiso(iso_indnum(iq),iPhase)) 298 END IF 297 299 enddo 298 300 else -
LMDZ6/trunk/libf/dynphy_lonlat/phylmd/iniphysiq_mod.F90
r4103 r4120 16 16 USE mod_phys_lmdz_para, ONLY: klon_omp ! number of columns (on local omp grid) 17 17 USE vertical_layers_mod, ONLY : init_vertical_layers 18 USE infotrac, ONLY: nqtot,nqo,nbtr,nqCO2,tracers,type_trac,& 19 conv_flg,pbl_flg,solsym,& 20 ok_isotopes,ok_iso_verif,ok_isotrac,& 21 ok_init_iso,niso_possibles,tnat,& 22 alpha_ideal,use_iso,iqiso,iso_indnum,& 23 indnum_fn_num,index_trac,& 24 niso,ntraceurs_zone,ntraciso,nqtottr 18 USE infotrac, ONLY: nbtr,nqCO2,tracers,isotopes,type_trac,conv_flg,pbl_flg,solsym,nqtottr 25 19 #ifdef CPP_StratAer 26 20 USE infotrac_phy, ONLY: nbtr_bin, nbtr_sulgas, id_OCS_strat, & … … 143 137 144 138 ! Initialize tracer names, numbers, etc. for physics 145 CALL init_infotrac_phy(nqtot,nqo,nbtr,nqtottr,nqCO2,tracers,type_trac,& 146 conv_flg,pbl_flg,solsym,& 147 ok_isotopes,ok_iso_verif,ok_isotrac,& 148 ok_init_iso,niso_possibles,tnat,& 149 alpha_ideal,use_iso,iqiso,iso_indnum,& 150 indnum_fn_num,index_trac,& 151 niso,ntraceurs_zone,ntraciso) 139 CALL init_infotrac_phy(type_trac, tracers, isotopes, nqtottr, nqCO2, pbl_flg, conv_flg, solsym) 152 140 153 141 ! Initializations for Reprobus -
LMDZ6/trunk/libf/misc/readTracFiles_mod.f90
r4075 r4120 1 1 MODULE readTracFiles_mod 2 2 3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, &4 removeComment, cat, checkList, str Idx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, fmsg, reduceExpr, & 4 removeComment, cat, checkList, str2int, strParse, strReplace, strTail, strIdx, maxlen, test, dispTable, get_in 5 5 USE trac_types_mod, ONLY: trac_type, isot_type, keys_type 6 6 … … 12 12 PUBLIC :: readTracersFiles, indexUpdate, setGeneration !--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS 13 13 PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS 14 PUBLIC :: getKey_init, getKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes 15 16 PUBLIC :: known_phases, old_phases, nphases, phases_names, & !--- VARIABLES RELATED TO THE PHASES 17 phases_sep, delPhase, addPhase, & !--- + ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME 18 old2newPhase, new2oldPhase 14 PUBLIC :: getKey_init, getKey, fGetKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes 15 16 PUBLIC :: addPhase, new2oldName, getPhase, & !--- FUNCTIONS RELATED TO THE PHASES 17 delPhase, old2newName, getiPhase, & !--- + ASSOCIATED VARIABLES 18 known_phases, old_phases, phases_sep, phases_names, nphases 19 20 PUBLIC :: oldH2OIso, newH2OIso !--- NEEDED FOR BACKWARD COMPATIBILITY (OLD traceur.def) 19 21 20 22 PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS 21 22 23 !------------------------------------------------------------------------------------------------------------------------------ 23 24 TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION … … 30 31 END INTERFACE getKey 31 32 !------------------------------------------------------------------------------------------------------------------------------ 33 INTERFACE fGetKey; MODULE PROCEDURE fgetKeyByIndex_s1, fgetKeyByName_s1; END INTERFACE fGetKey 32 34 INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset 33 35 INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m; END INTERFACE idxAncestor 34 36 INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m; END INTERFACE ancestor 35 INTERFACE addPhase; MODULE PROCEDURE addPhase_1, addPhase_m; END INTERFACE addPhase 37 INTERFACE addPhase; MODULE PROCEDURE addPhase_s1, addPhase_sm, addPhase_i1, addPhase_im; END INTERFACE addPhase 38 INTERFACE old2newName; MODULE PROCEDURE old2newName_1, old2newName_m; END INTERFACE old2newName 39 INTERFACE new2oldName; MODULE PROCEDURE new2oldName_1, new2oldName_m; END INTERFACE new2oldName 36 40 !------------------------------------------------------------------------------------------------------------------------------ 37 41 … … 49 53 LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists 50 54 LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation 55 56 !--- KEPT JUST TO MANAGE OLD WATER ISOTOPES NAMES 57 !--- Apart from that context, on limitaion on isotopes names (as long as they have a corresponding line in isotopes_params.def) 58 CHARACTER(LEN=maxlen), SAVE :: oldH2OIso(5) = ['eau', 'HDO', 'O18', 'O17', 'HTO' ] 59 CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H2[16]O', 'H[2]HO ', 'H2[18]O', 'H2[17]O', 'H[3]HO '] 60 51 61 52 62 !=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init) … … 87 97 INTEGER, INTENT(OUT) :: fType !--- Type of input file found 88 98 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tracs(:) 89 CHARACTER(LEN=maxlen), ALLOCATABLE :: 90 CHARACTER(LEN=maxlen) :: str, fname, mesg , oldH2O, newH2O99 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) 100 CHARACTER(LEN=maxlen) :: str, fname, mesg 91 101 INTEGER :: is, nsec, ierr, it, ntrac, ns, ip, ix 92 102 LOGICAL, ALLOCATABLE :: ll(:), lGen3(:) … … 142 152 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 143 153 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 144 tracs(it)%name = TRIM(s(3)) !--- Set %name: nameof the tracer145 tracs(it)%parent = tran0 !--- Set %parent: transporting fluid146 IF(ns == 4) tracs(it)%parent = s(4) !--- default: 'air' or defined in the file147 tracs(it)%phase = known_phases( 1:1)!--- Set %phase: tracer phase (default: "g"azeous)154 tracs(it)%name = old2newName(s(3), ip) !--- Set %name: name of the tracer 155 tracs(it)%parent = tran0 !--- Default transporting fluid name 156 IF(ns == 4) tracs(it)%parent = old2newName(s(4)) !--- Set %parent: parent of the tracer 157 tracs(it)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase (default: "g"azeous) 148 158 tracs(it)%component = TRIM(type_trac) !--- Set %component: model component name 149 159 tracs(it)%keys%key = ['hadv', 'vadv'] !--- Set %keys%key … … 151 161 END DO 152 162 CLOSE(90) 153 DO ip = 1, nphases !--- Deal with old water names154 oldH2O = 'H2O'//old_phases(ip:ip)155 newH2O = 'H2O'//phases_sep//known_phases(ip:ip)156 ix = strIdx(tracs(:)%name, oldH2O)157 IF(ix == 0) CYCLE158 tracs(ix)%name = newH2O !--- Set %name: name of the tracer159 WHERE(tracs(:)%parent == oldH2O) tracs(:)%parent = newH2O !--- Set %parent: transporting fluid160 tracs(ix)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase161 END DO162 163 CALL setGeneration(tracs) !--- Set %iGeneration and %gen0Name 163 WHERE(tracs%iGeneration == 3) tracs%type = 'tag' !--- Set %type: 'tracer' or 'tag'164 WHERE(tracs%iGeneration == 2) tracs%type = 'tag' !--- Set %type: 'tracer' or 'tag' 164 165 IF(test(checkTracers(tracs, fname, fname), lerr)) RETURN !--- Detect orphans and check phases 165 166 IF(test(checkUnique (tracs, fname, fname), lerr)) RETURN !--- Detect repeated tracers … … 167 168 tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components 168 169 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 169 CASE(2); IF(test(feedDBase(["tracer.def"], [type_trac]), lerr)) RETURN !=== SINGLE FILE, COMA-SEPARATED SECTIONS LIST170 CASE(2); IF(test(feedDBase(["tracer.def"], [type_trac], modname), lerr)) RETURN !=== SINGLE FILE, MULTIPLE SECTIONS 170 171 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 171 CASE(3); IF(test(feedDBase( trac_files , sections ), lerr)) RETURN !=== MULTIPLE FILES, ONE SECTION EACH FILE172 CASE(3); IF(test(feedDBase( trac_files , sections, modname), lerr)) RETURN !=== MULTIPLE FILES, SINGLE SECTION 172 173 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 173 174 END SELECT 174 175 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 175 176 176 IF(A NY([2,3] == fType) .AND. nsec > 1) THEN177 IF(tracs_merge) THEN 178 CALL msg('The multiple required sections will be MERGED.', modname)179 IF(test(mergeTracers(dBase, tracs), lerr)) RETURN180 ELSE181 CALL msg('The multiple required sections will be CUMULATED.',modname)182 IF(test(cumulTracers(dBase, tracs), lerr)) RETURN183 END IF184 WHERE(tracs%gen0Name(1:3) /= 'H2O') tracs%isInPhysics=.TRUE. !--- Set %isInPhysics: passed to physics185 CALL setDirectKeys(tracs) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChilds177 IF(ALL([2,3] /= fType)) RETURN 178 179 IF(nsec == 1) THEN; 180 tracs = dBase(1)%trac 181 ELSE IF(tracs_merge) THEN 182 CALL msg('The multiple required sections will be MERGED.', modname) 183 IF(test(mergeTracers(dBase, tracs), lerr)) RETURN 184 ELSE 185 CALL msg('The multiple required sections will be CUMULATED.', modname) 186 IF(test(cumulTracers(dBase, tracs), lerr)) RETURN 186 187 END IF 187 188 WHERE(tracs%gen0Name(1:3) /= 'H2O') tracs%isInPhysics=.TRUE. !--- Set %isInPhysics: passed to physics 189 CALL setDirectKeys(tracs) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChilds 188 190 END FUNCTION readTracersFiles 189 191 !============================================================================================================================== 190 192 191 193 !============================================================================================================================== 192 LOGICAL FUNCTION feedDBase(fnames, snames ) RESULT(lerr)194 LOGICAL FUNCTION feedDBase(fnames, snames, modname) RESULT(lerr) 193 195 ! Purpose: Read the sections "snames(is)" (coma-separated list) from each "fnames(is)" 194 196 ! file and create the corresponding tracers set descriptors in the database "dBase": … … 200 202 CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names 201 203 CHARACTER(LEN=*), INTENT(IN) :: snames(:) !--- Coma-deparated list of sections (one list each file) 202 INTEGER, ALLOCATABLE :: ndb(:) !--- Nuber of sections for each file 204 CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling routine name 205 INTEGER, ALLOCATABLE :: ndb(:) !--- Number of sections for each file 203 206 INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list 204 207 LOGICAL, ALLOCATABLE :: lTg(:) !--- Tagging tracers mask 205 CHARACTER(LEN=maxlen) :: fnm, snm , modname208 CHARACTER(LEN=maxlen) :: fnm, snm 206 209 INTEGER :: idb, i 207 210 LOGICAL :: ll 208 211 !------------------------------------------------------------------------------------------------------------------------------ 209 modname = 'feedDBase'210 212 !=== READ THE REQUIRED SECTIONS 211 213 ll = strCount(snames, ',', ndb) !--- Number of sections for each file … … 219 221 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 220 222 fnm = fnames(ixf(idb)); snm = dBase(idb)%name !--- FILE AND SECTION NAMES 223 lerr = ANY([(dispTraSection('RAW CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))]) 221 224 IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- EXPAND NAMES ; set %parent, %type, %component 222 225 CALL setGeneration (dBase(idb)%trac) !--- set %iGeneration, %genOName … … 225 228 CALL expandPhases (dBase(idb)%trac) !--- EXPAND PHASES ; set %phase 226 229 CALL sortTracers (dBase(idb)%trac) !--- SORT TRACERS 230 lerr = ANY([(dispTraSection('EXPANDED CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))]) 227 231 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 228 232 END DO 229 233 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 230 231 !=== DISPLAY BASIC INFORMATION232 lerr = ANY([( dispTraSection('Expanded list for section "'//TRIM(dBase(idb)%name)//'"', dBase(idb)%name, modname), &233 idb=1, SIZE(dBase) )])234 234 END FUNCTION feedDBase 235 235 !------------------------------------------------------------------------------------------------------------------------------ … … 406 406 DO it = 1, nt !=== EXPAND TRACERS AND PARENTS NAMES LISTS 407 407 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 408 ll = strParse(tr(it)%name, ',', ta, n=ntr)!--- Number of tracers408 ll = strParse(tr(it)%name, ',', ta, n=ntr) !--- Number of tracers 409 409 ll = strParse(tr(it)%parent, ',', pa, n=npr) !--- Number of parents 410 410 DO ipr=1,npr !--- Loop on parents list elts 411 411 DO itr=1,ntr !--- Loop on tracers list elts 412 412 i = iq+itr-1+(ipr-1)*ntr 413 ttr(i)%name = TRIM(ta(itr)); ttr(i)%parent = pa(ipr) 414 ttr(i)%keys = keys_type(ta(itr), tr(it)%keys%key, tr(it)%keys%val) 413 ttr(i)%name = TRIM(ta(itr)) 414 ttr(i)%parent = TRIM(pa(ipr)) 415 ttr(i)%keys = keys_type(ta(itr), tr(it)%keys%key, tr(it)%keys%val) 415 416 END DO 416 417 END DO 417 ttr(iq:iq+ntr*npr-1)%type = tr(it)%type !--- Duplicating type 418 ttr(iq:iq+ntr*npr-1)%type = tr(it)%type !--- Duplicating type 419 ttr(iq:iq+ntr*npr-1)%component = tr(it)%component !--- Duplicating type 418 420 iq = iq + ntr*npr 419 421 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 440 442 tr(:)%iGeneration = -1 !--- error if -1 441 443 nq = SIZE(tr, DIM=1) !--- Number of tracers lines 442 lg = tr(:)%parent == tran0 !--- F irst generation tracers flag443 WHERE(lg) tr(:)%iGeneration = 0 !--- First generationtracers444 lg = tr(:)%parent == tran0 !--- Flag for generation 0 tracers 445 WHERE(lg) tr(:)%iGeneration = 0 !--- Generation 0 tracers 444 446 445 447 !=== Determine generation for each tracer … … 511 513 ll = tr(:)%name==TRIM(tnam) !--- Mask for current tracer name 512 514 IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated 513 IF(tr(iq)%iGeneration> 1) THEN514 tdup(iq) = tnam !--- gen> 1: MUST be unique515 IF(tr(iq)%iGeneration>0) THEN 516 tdup(iq) = tnam !--- gen>0: MUST be unique 515 517 ELSE 516 518 DO ip=1,nphases; p=known_phases(ip:ip) !--- Loop on known phases … … 531 533 SUBROUTINE expandPhases(tr) 532 534 !------------------------------------------------------------------------------------------------------------------------------ 533 ! Purpose: Expand the phases in the tracers descriptor "tr". 535 ! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique". 534 536 !------------------------------------------------------------------------------------------------------------------------------ 535 537 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector … … 538 540 INTEGER, ALLOCATABLE :: i0(:) 539 541 CHARACTER(LEN=maxlen) :: nam, pha, trn 542 CHARACTER(LEN=1) :: p 540 543 INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n 541 544 LOGICAL :: lTg, lEx … … 544 547 nt = 0 545 548 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS 546 IF(tr(iq)%iGeneration /= 1) CYCLE547 nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/= 1) !--- Number of childs of tr(iq)549 IF(tr(iq)%iGeneration /= 0) CYCLE !--- Only deal with generation 0 tracers 550 nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=0) !--- Number of childs of tr(iq) 548 551 tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq) 549 552 np = LEN_TRIM(tr(iq)%phase) !--- Number of phases of tr(iq) 550 553 nt = nt + (1+nc) * np !--- Number of tracers after expansion 551 554 END DO 552 ALLOCATE(ttr(nt)) 555 ALLOCATE(ttr(nt)) !--- Version of "tr" after phases expansion 553 556 it = 1 !--- Current "ttr(:)" index 554 557 DO iq = 1, nq !--- Loop on "tr(:)" indexes 555 558 lTg = tr(iq)%type=='tag' !--- Current tracer is a tag 556 559 i0 = strFind(tr(:)%name, TRIM(tr(iq)%gen0Name), n) !--- Indexes of first generation ancestor copies 557 np = SUM( [( LEN_TRIM(tr(i0(i))%phase),i=1,n )],1) !--- Number of phases for current tracer tr(iq)558 lEx = np>1 !--- Need of a phase suffix559 IF(lTg) lEx =lEx.AND.tr(iq)%iGeneration>1 !--- No phase suffix for first generationtags560 DO i=1,n !=== LOOP ON FIRST GENERATIONANCESTORS561 jq =i0(i) !--- tr(jq): ith copy of 1st gen. ancestor oftr(iq)562 IF(tr(iq)%iGeneration== 1) jq=iq !--- Generation 1:current tracer phases only560 np = SUM([( LEN_TRIM(tr(i0(i))%phase),i=1,n )], 1) !--- Number of phases for current tracer tr(iq) 561 lEx = np>1 !--- Phase suffix only required if phases number is > 1 562 IF(lTg) lEx = lEx .AND. tr(iq)%iGeneration>0 !--- No phase suffix for generation 0 tags 563 DO i=1,n !=== LOOP ON GENERATION 0 ANCESTORS 564 jq = i0(i) !--- tr(jq): ith tracer with same gen 0 ancestor as tr(iq) 565 IF(tr(iq)%iGeneration==0) jq=iq !--- Generation 0: count the current tracer phases only 563 566 pha = tr(jq)%phase !--- Phases list for tr(jq) 564 DO ip=1,LEN_TRIM(pha) !=== LOOP ON PHASES LISTS 565 trn=TRIM(tr(iq)%name); nam=trn !--- Tracer name (regular case) 567 DO ip = 1, LEN_TRIM(pha) !=== LOOP ON PHASES LISTS 568 p = pha(ip:ip) 569 trn = TRIM(tr(iq)%name); nam = trn !--- Tracer name (regular case) 566 570 IF(lTg) nam = TRIM(tr(iq)%parent) !--- Parent name (tagging case) 567 IF(lEx) nam = TRIM(nam)//phases_sep//pha(ip:ip)!--- Phase extension needed571 IF(lEx) nam = addPhase(nam, p ) !--- Phase extension needed 568 572 IF(lTg) nam = TRIM(nam)//'_'//TRIM(trn) !--- <parent>_<name> for tags 569 573 ttr(it) = tr(iq) !--- Same <key>=<val> pairs 570 ttr(it)%name = TRIM(nam)!--- Name with possibly phase suffix574 ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix 571 575 ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor 572 ttr(it)%phase = pha(ip:ip)!--- Single phase entry573 IF(lEx .AND.tr(iq)%iGeneration>1) THEN574 ttr(it)%parent = TRIM(ttr(it)%parent)//phases_sep//pha(ip:ip)575 ttr(it)%gen0Name = TRIM(ttr(it)%gen0Name)//phases_sep//pha(ip:ip)576 ttr(it)%phase = p !--- Single phase entry 577 IF(lEx .AND. tr(iq)%iGeneration>0) THEN 578 ttr(it)%parent = addPhase(ttr(it)%parent, p) 579 ttr(it)%gen0Name = addPhase(ttr(it)%gen0Name, p) 576 580 END IF 577 it =it+1581 it = it+1 578 582 END DO 579 IF(tr(iq)%iGeneration== 1) EXIT !--- Break phase loop for gen 1583 IF(tr(iq)%iGeneration==0) EXIT !--- Break phase loop for gen 0 580 584 END DO 581 585 END DO … … 590 594 !------------------------------------------------------------------------------------------------------------------------------ 591 595 ! Purpose: Sort tracers: 592 ! * Put water at first places, in the "known_phases" order.596 ! * Put water at the beginning of the vector, in the "known_phases" order. 593 597 ! * lGrowGen == T: in ascending generations numbers. 594 598 ! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other. 595 599 ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END 596 600 !------------------------------------------------------------------------------------------------------------------------------ 597 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 601 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 602 ! TYPE(trac_type), ALLOCATABLE :: ttr(:) 603 INTEGER, ALLOCATABLE :: iy(:), iz(:) 598 604 INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k 599 INTEGER, ALLOCATABLE :: iy(:), iz(:)600 605 !------------------------------------------------------------------------------------------------------------------------------ 601 606 nq = SIZE(tr) 602 iy = [(k, k=1, nq)]603 607 DO ip = nphases, 1, -1 604 iq = strIdx(tr acers(:)%name, 'H2O'//phases_sep//known_phases(ip:ip))605 IF(iq /=0) iy = [iq, iy(1:iq-1), iy(iq:nq)]606 END DO607 tr = tr(iy) !--- Water displaces at first positions 608 iq = 1608 iq = strIdx(tr(:)%name, addPhase('H2O', ip)) 609 IF(iq == 0) CYCLE 610 tr = tr([iq, 1:iq-1, iq+1:nq]) 611 ! tr(:)%name = nam 612 END DO 609 613 IF(lSortByGen) THEN 614 iq = 1 610 615 ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations 611 616 DO ig = 0, ng !--- Loop on generations … … 616 621 END DO 617 622 ELSE 618 DO jq = 1, nq !--- Loop on first generation tracers 619 IF(tr(jq)%iGeneration /= 1) CYCLE !--- Skip generations >= 1 620 ix(iq) = jq !--- First generation ancestor index first 621 iq = iq + 1 623 iq = 1 624 DO jq = 1, nq !--- Loop on generation 0 tracers 625 IF(tr(jq)%iGeneration /= 0) CYCLE !--- Skip generations /= 0 626 ix(iq) = jq !--- Generation 0 ancestor index first 627 iq = iq + 1 !--- Next "iq" for next generations tracers 622 628 iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name)) !--- Indexes of "tr(jq)" childs in "tr(:)" 623 ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Generations numberof the "tr(jq)" family624 DO ig = 2, ng !--- Loop on generations for the tr(jq)family629 ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations of the "tr(jq)" family 630 DO ig = 1, ng !--- Loop on generations of the "tr(jq)" family 625 631 iz = find(tr(iy)%iGeneration, ig, n) !--- Indexes of the tracers "tr(iy(:))" of generation "ig" 626 632 ix(iq:iq+n-1) = iy(iz) !--- Same indexes in "tr(:)" … … 724 730 tnam = TRIM(t1(iq)%name) !--- Original name 725 731 IF(COUNT(t1%name == tnam) == 1) CYCLE !--- Current tracer is not duplicated: finished 726 tnam_new = TRIM(tnam)// phases_sep//TRIM(sections(is)%name)!--- Same with section extension732 tnam_new = TRIM(tnam)//'_'//TRIM(sections(is)%name) !--- Same with section extension 727 733 nq = SUM(nt(1:is-1)) !--- Number of tracers in previous sections 728 734 ns = nt(is) !--- Number of tracers in the current section … … 757 763 INTEGER :: idb, iq, nq 758 764 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) 765 CHARACTER(LEN=maxlen), ALLOCATABLE :: phas(:) 759 766 TYPE(trac_type), POINTER :: tm(:) 760 767 lerr = .FALSE. … … 762 769 tm => dBase(idb)%trac 763 770 nq = SIZE(tm) 764 IF(test(getKeyByName_im('hadv', hadv, tm(:)%name, tm(:)%keys),lerr)) RETURN 765 IF(test(getKeyByName_im('vadv', vadv, tm(:)%name, tm(:)%keys),lerr)) RETURN 771 !--- BEWARE ! Can't use the "getKeyByName" functions yet. 772 ! Names must first include the phases for tracers defined on multiple lines. 773 hadv = str2int([(fgetKey(iq, 'hadv', tm(:)%keys, '10'), iq=1, nq)]) 774 vadv = str2int([(fgetKey(iq, 'vadv', tm(:)%keys, '10'), iq=1, nq)]) 775 phas = [(fgetKey(iq, 'phases',tm(:)%keys, 'g' ), iq=1, nq)] 766 776 CALL msg(TRIM(message)//':', modname) 767 IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','short name','parent ','igen ','phase '], & 768 cat(tm(:)%name, tm(:)%parent, tm(:)%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%iGeneration)), lerr)) RETURN 777 IF(tm(1)%parent == '') THEN 778 IF(test(dispTable('iiiss', ['iq ','hadv ','vadv ','name ','phase '], cat(tm%name, phas), cat([(iq, iq=1, nq)], & 779 hadv, vadv), sub=modname), lerr)) RETURN 780 ELSE 781 IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','name ','parent','igen ','phase '], cat(tm%name, tm%parent, & 782 tm%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm%iGeneration), sub=modname), lerr)) RETURN 783 END IF 769 784 END FUNCTION dispTraSection 770 785 !============================================================================================================================== … … 825 840 SUBROUTINE indexUpdate(tr) 826 841 TYPE(trac_type), INTENT(INOUT) :: tr(:) 827 INTEGER :: iq, ig, ng, ngen842 INTEGER :: iq, ig, ng, igen, ngen 828 843 INTEGER, ALLOCATABLE :: ix(:) 829 844 tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index 830 845 ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.) 831 846 DO iq = 1, SIZE(tr) 832 ng = tr(iq)%iGeneration !--- Generation of the current tracer 833 ix = idxAncestor(tr, igen = ng); ix = PACK(ix, ix/=0) !--- Indexes of the tracers with ancestor tr(iq) 834 !--- Childs indexes in growing generation order 835 tr(iq)%iqDescen = [( PACK(ix, MASK = tr(ix)%iGeneration == ig), ig = ng+1, ngen)] 836 tr(iq)%nqDescen = SUM( [( COUNT(tr(ix)%iGeneration == ig), ig = ng+1, ngen)] ) 837 tr(iq)%nqChilds = COUNT(tr(ix)%iGeneration == ng+1) 847 ig = tr(iq)%iGeneration 848 IF(ALLOCATED(tr(iq)%iqDescen)) DEALLOCATE(tr(iq)%iqDescen) 849 ALLOCATE(tr(iq)%iqDescen(0)) 850 ix = idxAncestor(tr, igen=ig) !--- Ancestor of generation "ng" for each tr 851 DO igen = ig+1, ngen 852 tr(iq)%iqDescen = [tr(iq)%iqDescen, find(ix==iq .AND. tr%iGeneration==igen)] 853 tr(iq)%nqDescen = SIZE(tr(iq)%iqDescen) 854 IF(igen == ig+1) tr(iq)%nqChilds=tr(iq)%nqDescen 855 END DO 838 856 END DO 839 857 END SUBROUTINE indexUpdate … … 847 865 !=== NOTES: ==== 848 866 !=== * Most of the "isot" components have been defined in the calling routine (initIsotopes): ==== 849 !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, i TraPha(:,:), iZonPhi(:,:)====867 !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqTraPha(:,:), itZonPhi(:,:) ==== 850 868 !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== 851 869 !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== … … 909 927 ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase) 910 928 END IF 929 930 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) 931 CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.) 932 911 933 lerr = dispIsotopes(isot, 'Isotopes parameters read from file', modname) 912 934 … … 930 952 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 931 953 TYPE(trac_type), POINTER :: t(:), t1 932 TYPE(isot_type), POINTER :: s954 TYPE(isot_type), POINTER :: i 933 955 934 956 t => trac 935 957 936 p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration== 2) !--- Parents of 2nd generationisotopes958 p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==1) !--- Parents of generation 1 isotopes 937 959 CALL strReduce(p, nbIso) 938 960 ALLOCATE(isot(nbIso)) … … 943 965 isot(:)%parent = p 944 966 DO ic = 1, SIZE(p) !--- Loop on isotopes classes 945 s=> isot(ic)946 iname = s%parent !--- Current isotopes class name (parent tracer name)967 i => isot(ic) 968 iname = i%parent !--- Current isotopes class name (parent tracer name) 947 969 948 970 !=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname") 949 971 ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g' 950 972 str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname" 951 s%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname"952 ALLOCATE( s%keys(s%niso))953 FORALL(it = 1: s%niso) s%keys(it)%name = str(it)973 i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" 974 ALLOCATE(i%keys(i%niso)) 975 FORALL(it = 1:i%niso) i%keys(it)%name = str(it) 954 976 955 977 !=== Geographic tagging tracers descending on tracer "iname": mask, names, number 956 ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 3957 s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll)!--- Tagging zones names for isotopes category "iname"958 CALL strReduce( s%zone)959 s%nzone = SIZE(s%zone) !--- Tagging zones number for isotopes category "iname"978 ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 2 979 i%zone = PACK(strTail(t(:)%name,'_'), MASK = ll) !--- Tagging zones names for isotopes category "iname" 980 CALL strReduce(i%zone) 981 i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname" 960 982 961 983 !=== Geographic tracers of the isotopes childs of tracer "iname" (same for each phase of "iname") … … 963 985 str = PACK(delPhase(t(:)%name), MASK=ll) 964 986 CALL strReduce(str) 965 s%ntiso = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso]966 ALLOCATE( s%trac(s%ntiso))967 FORALL(it = 1: s%niso) s%trac(it) = s%keys(it)%name968 FORALL(it = s%niso+1:s%ntiso) s%trac(it) = str(it-s%niso)987 i%ntiso = i%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso] 988 ALLOCATE(i%trac(i%ntiso)) 989 FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name 990 FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso) 969 991 970 992 !=== Phases for tracer "iname" 971 s%phase = ''972 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phase = TRIM(s%phase)//ph; END DO973 s%nphas = LEN_TRIM(s%phase) !--- Equal to "nqo" for water993 i%phase = '' 994 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 995 i%nphas = LEN_TRIM(i%phase) !--- Equal to "nqo" for water 974 996 975 997 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) 976 998 DO iq = 1, SIZE(t) 977 999 t1 => trac(iq) 978 IF(delPhase(t1%gen0Name) /= iname) CYCLE!--- Only deal with tracers descending on "iname"1000 IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname" 979 1001 t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" 980 t1%iso_iName = strIdx( s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list981 t1%iso_iZone = strIdx( s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list982 t1%iso_iPhase = INDEX( s%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list983 IF(t1%iGeneration /= 3) t1%iso_iZone = 0 !--- Skip possible generation 2tagging tracers1002 t1%iso_iName = strIdx(i%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list 1003 t1%iso_iZone = strIdx(i%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list 1004 t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list 1005 IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 tagging tracers 984 1006 END DO 985 1007 986 1008 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 987 1009 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 988 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phase(ip:ip))), it=1, s%ntiso), ip=1, s%nphas)], & 989 [s%ntiso, s%nphas] ) 990 1010 i%iqTraPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], & 1011 [i%ntiso, i%nphas] ) 991 1012 !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes 992 s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzone), it=1, s%niso )], &993 [ s%nzone, s%niso] )1013 i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], & 1014 [i%nzone, i%niso] ) 994 1015 END DO 995 1016 … … 1023 1044 END DO 1024 1045 END DO 1025 IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)' )),&1026 lerr)) RETURN1046 IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)', & 1047 sub=modname)), lerr)) RETURN 1027 1048 DEALLOCATE(ttl, val) 1028 1049 END DO … … 1078 1099 IF(jd == 0) RETURN 1079 1100 DO ik = 1, SIZE(t(jd)%keys%key) 1080 CALL get_in(t(jd)%keys%key(ik), val, ' zzzz')1081 IF(val /= ' zzzz') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)1101 CALL get_in(t(jd)%keys%key(ik), val, '*none*') 1102 IF(val /= '*none*') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) 1082 1103 END DO 1083 1104 END SUBROUTINE addKeysFromDef … … 1127 1148 END SUBROUTINE getKey_init 1128 1149 !============================================================================================================================== 1129 CHARACTER(LEN=maxlen) FUNCTION fgetKey (itr, keyn, ky, def_val) RESULT(out)1130 !------------------------------------------------------------------------------------------------------------------------------ 1131 ! Purpose: Internal function ; get a key value in string format (this is the returned argument).1150 CHARACTER(LEN=maxlen) FUNCTION fgetKeyByIndex_s1(itr, keyn, ky, def_val) RESULT(val) 1151 !------------------------------------------------------------------------------------------------------------------------------ 1152 ! Purpose: Internal function ; get a string formatted key value (returned argument) from its name and the tracer index. 1132 1153 !------------------------------------------------------------------------------------------------------------------------------ 1133 1154 INTEGER, INTENT(IN) :: itr … … 1136 1157 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val 1137 1158 !------------------------------------------------------------------------------------------------------------------------------ 1138 INTEGER :: ik 1139 ik = 0; IF(itr>0 .AND. itr<=SIZE(ky)) ik = strIdx(ky(itr)%key(:), keyn) 1140 out = ''; IF(ik /= 0) out = ky(itr)%val(ik) !--- Key was found 1141 IF(PRESENT(def_val) .AND. ik == 0) out = def_val !--- Default value from arguments 1142 END FUNCTION fgetKey 1159 INTEGER :: iky 1160 iky = 0; IF(itr > 0 .AND. itr <= SIZE(ky)) iky = strIdx(ky(itr)%key(:), keyn) 1161 val = ''; IF(iky /= 0) val = ky(itr)%val(iky) !--- Key was found 1162 IF(PRESENT(def_val) .AND. iky == 0) val = def_val !--- Default value from arguments 1163 END FUNCTION fgetKeyByIndex_s1 1164 !============================================================================================================================== 1165 CHARACTER(LEN=maxlen) FUNCTION fgetKeyByName_s1(tname, keyn, ky, def_val, lerr) RESULT(val) 1166 !------------------------------------------------------------------------------------------------------------------------------ 1167 ! Purpose: Internal function ; get a string formatted key value (returned argument) from its name and the tracer name. 1168 !------------------------------------------------------------------------------------------------------------------------------ 1169 CHARACTER(LEN=*), INTENT(IN) :: tname, keyn 1170 TYPE(keys_type), INTENT(IN) :: ky(:) 1171 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val 1172 LOGICAL, OPTIONAL, INTENT(OUT) :: lerr 1173 !------------------------------------------------------------------------------------------------------------------------------ 1174 INTEGER :: iky, itr 1175 val = ''; iky = 0 1176 itr = strIdx(ky(:)%name, tname) !--- Get the index of the wanted tracer 1177 IF(PRESENT(lerr)) lerr = itr==0; IF(itr == 0) RETURN 1178 IF(itr > 0 .AND. itr <= SIZE(ky)) iky = strIdx(ky(itr)%key(:), keyn) 1179 IF(iky /= 0) val = ky(itr)%val(iky) !--- Key was found 1180 IF(PRESENT(def_val) .AND. iky == 0) val = def_val !--- Default value from arguments 1181 END FUNCTION fgetKeyByName_s1 1143 1182 !============================================================================================================================== 1144 1183 LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr) … … 1151 1190 CHARACTER(LEN=*), INTENT(IN) :: tname 1152 1191 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1153 INTEGER :: is 1154 lerr = .FALSE. 1192 CHARACTER(LEN=maxlen) :: tnam 1193 INTEGER, ALLOCATABLE :: is(:) 1194 INTEGER :: i, itr 1195 tnam = delPhase(strHead(tname,'_',.FALSE.)) !--- Remove tag and phase 1155 1196 IF(PRESENT(ky)) THEN 1156 val = getKeyByName_prv(keyn, tname , ky); IF(val /= '') RETURN !--- "ky" and "tnam" 1157 val = getKeyByName_prv(keyn, delPhase(strHead(tname,'_')), ky) !--- "ky" and "tnam" without phase 1197 val = fgetKeyByName_s1(tname, keyn, ky, lerr=lerr) !--- "ky" and "tname" 1198 IF(val /= '' .OR. lerr) RETURN 1199 val = fgetKeyByName_s1(tnam, keyn, ky, lerr=lerr) !--- "ky" and "tnam" 1158 1200 ELSE 1159 1201 IF(.NOT.ALLOCATED(tracers)) RETURN 1160 val = getKeyByName_prv(keyn, tname, tracers(:)%keys); IF(val /= '') RETURN !--- "tracers" and "tnam" 1202 val = fgetKeyByName_s1(tname, keyn, tracers(:)%keys, lerr=lerr) !--- "tracers" and "tname" 1203 IF(val /= ''.AND..NOT.lerr) RETURN 1161 1204 IF(.NOT.ALLOCATED(isotopes)) RETURN 1162 1205 IF(SIZE(isotopes) == 0) RETURN 1163 DO is = 1, SIZE(isotopes); IF(strIdx(isotopes(is)%keys(:)%name, delPhase(strHead(tname,'_'))) /= 0) EXIT; END DO 1164 IF(is /= 0) val = getKeyByName_prv(keyn, tname, isotopes(is)%keys(:)) !--- "isotopes" and "tnam" without phase 1206 !--- Search the "is" isotopes class index of the isotope named "tnam" 1207 is = find([(ANY(isotopes(i)%keys(:)%name == tnam), i=1, SIZE(isotopes))]) 1208 IF(test(SIZE(is) == 0,lerr)) RETURN 1209 val = fgetKeyByName_s1(tname, keyn, isotopes(is(1))%keys(:),lerr=lerr)!--- "isotopes" and "tnam" 1165 1210 END IF 1166 1167 CONTAINS1168 1169 FUNCTION getKeyByName_prv(keyn, tname, ky) RESULT(val)1170 CHARACTER(LEN=maxlen) :: val1171 CHARACTER(LEN=*), INTENT(IN) :: keyn1172 CHARACTER(LEN=*), INTENT(IN) :: tname1173 TYPE(keys_type), INTENT(IN) :: ky(:)1174 INTEGER :: itr, iky1175 val = ''; iky = 01176 itr = strIdx(ky(:)%name, tname); IF(itr==0) RETURN !--- Get the index of the wanted tracer1177 IF(itr /= 0) iky = strIdx(ky(itr)%key(:), keyn); IF(iky==0) RETURN !--- Wanted key index1178 val = ky(itr)%val(iky)1179 END FUNCTION getKeyByName_prv1180 1181 1211 END FUNCTION getKeyByName_s1 1182 1212 !============================================================================================================================== 1183 LOGICAL FUNCTION getKeyByName_sm(keyn, val, tnam , ky) RESULT(lerr)1213 LOGICAL FUNCTION getKeyByName_sm(keyn, val, tname, ky) RESULT(lerr) 1184 1214 CHARACTER(LEN=*), INTENT(IN) :: keyn 1185 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1186 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1187 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1188 CHARACTER(LEN=maxlen), POINTER :: n(:) 1189 INTEGER :: iq 1190 n => tracers(:)%keys%name; IF(PRESENT(tnam)) n => tnam(:) 1191 ALLOCATE(val(SIZE(n))) 1192 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) 1193 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) 1215 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1216 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tname(:) 1217 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1218 TYPE(keys_type), POINTER :: k(:) 1219 CHARACTER(LEN=maxlen), ALLOCATABLE :: n(:) 1220 INTEGER :: iq, nq 1221 IF(test(.NOT.(PRESENT(tname).OR.PRESENT(ky)), lerr)) RETURN 1222 IF(PRESENT(ky )) nq = SIZE(ky%name) 1223 IF(PRESENT(tname)) nq = SIZE( tname) 1224 ALLOCATE(val(nq)) 1225 IF(PRESENT(tname)) THEN 1226 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq), ky), iq=1, nq)]) 1227 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq) ), iq=1, nq)]) 1228 ELSE; lerr = ANY([(getKeyByName_s1(keyn, val(iq), ky(iq)%name, ky), iq=1, nq)]) 1229 END IF 1194 1230 END FUNCTION getKeyByName_sm 1195 1231 !============================================================================================================================== 1196 LOGICAL FUNCTION getKeyByName_i1(keyn, val, tnam , ky) RESULT(lerr)1232 LOGICAL FUNCTION getKeyByName_i1(keyn, val, tname, ky) RESULT(lerr) 1197 1233 CHARACTER(LEN=*), INTENT(IN) :: keyn 1198 1234 INTEGER, INTENT(OUT) :: val 1199 CHARACTER(LEN=*), INTENT(IN) :: tnam 1235 CHARACTER(LEN=*), INTENT(IN) :: tname 1200 1236 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1201 1237 CHARACTER(LEN=maxlen) :: sval 1202 1238 INTEGER :: ierr 1203 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam , ky)1204 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam )1205 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam )//'" is missing', modname, lerr), lerr)) RETURN1239 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tname, ky) 1240 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tname) 1241 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN 1206 1242 READ(sval, *, IOSTAT=ierr) val 1207 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam )//'" is not an integer', modname, lerr), lerr)) RETURN1243 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, lerr), lerr)) RETURN 1208 1244 END FUNCTION getKeyByName_i1 1209 1245 !============================================================================================================================== 1210 LOGICAL FUNCTION getKeyByName_im(keyn, val, tnam , ky) RESULT(lerr)1246 LOGICAL FUNCTION getKeyByName_im(keyn, val, tname, ky) RESULT(lerr) 1211 1247 CHARACTER(LEN=*), INTENT(IN) :: keyn 1212 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1213 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1214 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1215 CHARACTER(LEN=maxlen), POINTER :: n(:) 1216 INTEGER :: iq 1217 n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) 1218 ALLOCATE(val(SIZE(n))) 1219 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) 1220 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) 1248 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1249 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tname(:) 1250 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1251 TYPE(keys_type), POINTER :: k(:) 1252 CHARACTER(LEN=maxlen), ALLOCATABLE :: n(:) 1253 INTEGER :: iq, nq 1254 IF(test(.NOT.(PRESENT(tname).OR.PRESENT(ky)), lerr)) RETURN 1255 IF(PRESENT(ky )) nq = SIZE(ky%name) 1256 IF(PRESENT(tname)) nq = SIZE( tname) 1257 ALLOCATE(val(nq)) 1258 IF(PRESENT(tname)) THEN 1259 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), tname(iq), ky), iq=1, nq)]) 1260 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), tname(iq) ), iq=1, nq)]) 1261 ELSE; lerr = ANY([(getKeyByName_i1(keyn, val(iq), ky(iq)%name, ky), iq=1, nq)]) 1262 END IF 1221 1263 END FUNCTION getKeyByName_im 1222 1264 !============================================================================================================================== 1223 LOGICAL FUNCTION getKeyByName_r1(keyn, val, tnam , ky) RESULT(lerr)1265 LOGICAL FUNCTION getKeyByName_r1(keyn, val, tname, ky) RESULT(lerr) 1224 1266 CHARACTER(LEN=*), INTENT(IN) :: keyn 1225 1267 REAL, INTENT(OUT) :: val 1226 CHARACTER(LEN=*), INTENT(IN) :: tnam 1268 CHARACTER(LEN=*), INTENT(IN) :: tname 1227 1269 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1228 1270 CHARACTER(LEN=maxlen) :: sval 1229 1271 INTEGER :: ierr 1230 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam , ky)1231 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam )1232 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam )//'" is missing', modname, lerr), lerr)) RETURN1272 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tname, ky) 1273 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tname) 1274 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN 1233 1275 READ(sval, *, IOSTAT=ierr) val 1234 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam )//'" is not a real', modname, lerr), lerr)) RETURN1276 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a real', modname, lerr), lerr)) RETURN 1235 1277 END FUNCTION getKeyByName_r1 1236 1278 !============================================================================================================================== 1237 LOGICAL FUNCTION getKeyByName_rm(keyn, val, tnam , ky) RESULT(lerr)1279 LOGICAL FUNCTION getKeyByName_rm(keyn, val, tname, ky) RESULT(lerr) 1238 1280 CHARACTER(LEN=*), INTENT(IN) :: keyn 1239 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1240 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1241 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1242 CHARACTER(LEN=maxlen), POINTER :: n(:) 1243 INTEGER :: iq 1244 n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) 1245 ALLOCATE(val(SIZE(n))) 1246 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) 1247 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) 1281 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1282 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tname(:) 1283 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1284 TYPE(keys_type), POINTER :: k(:) 1285 CHARACTER(LEN=maxlen), ALLOCATABLE :: n(:) 1286 INTEGER :: iq, nq 1287 IF(test(.NOT.(PRESENT(tname).OR.PRESENT(ky)), lerr)) RETURN 1288 IF(PRESENT(ky )) nq = SIZE(ky%name) 1289 IF(PRESENT(tname)) nq = SIZE( tname) 1290 ALLOCATE(val(nq)) 1291 IF(PRESENT(tname)) THEN 1292 IF( PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), tname(iq), ky), iq=1, nq)]) 1293 IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), tname(iq) ), iq=1, nq)]) 1294 ELSE; lerr = ANY([(getKeyByName_r1(keyn, val(iq), ky(iq)%name, ky), iq=1, nq)]) 1295 END IF 1248 1296 END FUNCTION getKeyByName_rm 1249 1297 !============================================================================================================================== … … 1276 1324 END FUNCTION delPhase 1277 1325 !------------------------------------------------------------------------------------------------------------------------------ 1278 CHARACTER(LEN=maxlen) FUNCTION addPhase_ 1(s,pha,ph_sep) RESULT(out)1326 CHARACTER(LEN=maxlen) FUNCTION addPhase_s1(s,pha) RESULT(out) 1279 1327 CHARACTER(LEN=*), INTENT(IN) :: s 1280 1328 CHARACTER(LEN=1), INTENT(IN) :: pha 1281 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep1282 CHARACTER(LEN=1) :: psep1283 1329 INTEGER :: l, i 1284 1330 out = s 1285 1331 IF(s == '') RETURN !--- Empty string: nothing to do 1286 psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep1287 1332 i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names 1288 1333 l = LEN_TRIM(s) 1289 IF(i == 0) out = TRIM(s)// TRIM(psep)//pha !--- <var> => return <var><sep><pha>1290 IF(i /= 0) out = s(1:i-1)// TRIM(psep)//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag>1291 END FUNCTION addPhase_ 11292 !------------------------------------------------------------------------------------------------------------------------------ 1293 FUNCTION addPhase_ m(s,pha,ph_sep) RESULT(out)1334 IF(i == 0) out = TRIM(s)//phases_sep//pha !--- <var> => return <var><sep><pha> 1335 IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag> 1336 END FUNCTION addPhase_s1 1337 !------------------------------------------------------------------------------------------------------------------------------ 1338 FUNCTION addPhase_sm(s,pha) RESULT(out) 1294 1339 CHARACTER(LEN=*), INTENT(IN) :: s(:) 1295 1340 CHARACTER(LEN=1), INTENT(IN) :: pha 1296 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep1297 1341 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1298 CHARACTER(LEN=1) :: psep1299 1342 INTEGER :: k 1300 psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep 1301 out = [( addPhase_1(s(k), pha, psep), k=1, SIZE(s) )] 1302 END FUNCTION addPhase_m 1303 !------------------------------------------------------------------------------------------------------------------------------ 1304 1305 CHARACTER(LEN=1) FUNCTION old2newPhase(op) RESULT(np) 1306 CHARACTER(LEN=1), INTENT(IN) :: op 1307 np = known_phases(INDEX(old_phases,op):INDEX(old_phases,op)) 1308 END FUNCTION old2newPhase 1309 1310 CHARACTER(LEN=1) FUNCTION new2oldPhase(np) RESULT(op) 1311 CHARACTER(LEN=1), INTENT(IN) :: np 1312 op = old_phases(INDEX(known_phases,np):INDEX(known_phases,np)) 1313 END FUNCTION new2oldPhase 1343 out = [( addPhase_s1(s(k), pha), k=1, SIZE(s) )] 1344 END FUNCTION addPhase_sm 1345 !------------------------------------------------------------------------------------------------------------------------------ 1346 CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,phases) RESULT(out) 1347 CHARACTER(LEN=*), INTENT(IN) :: s 1348 INTEGER, INTENT(IN) :: ipha 1349 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases 1350 out = s 1351 IF(s == '') RETURN !--- Empty string: nothing to do 1352 IF(ipha==0) RETURN !--- Null index: no phase to add 1353 IF( PRESENT(phases)) out = addPhase_s1(s, phases(ipha:ipha)) 1354 IF(.NOT.PRESENT(phases)) out = addPhase_s1(s, known_phases(ipha:ipha)) 1355 END FUNCTION addPhase_i1 1356 !------------------------------------------------------------------------------------------------------------------------------ 1357 FUNCTION addPhase_im(s,ipha,phases) RESULT(out) 1358 CHARACTER(LEN=*), INTENT(IN) :: s(:) 1359 INTEGER, INTENT(IN) :: ipha 1360 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases 1361 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1362 INTEGER :: k 1363 IF( PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, phases), k=1, SIZE(s) )] 1364 IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )] 1365 END FUNCTION addPhase_im 1366 !------------------------------------------------------------------------------------------------------------------------------ 1367 1368 1369 !============================================================================================================================== 1370 !=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================ 1371 !============================================================================================================================== 1372 INTEGER FUNCTION getiPhase(tname, phases) RESULT(iPhase) 1373 CHARACTER(LEN=*), INTENT(IN) :: tname 1374 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases 1375 CHARACTER(LEN=maxlen) :: phase 1376 IF( PRESENT(phases)) phase = getPhase(tname, phases, iPhase) 1377 IF(.NOT.PRESENT(phases)) phase = getPhase(tname, known_phases, iPhase) 1378 END FUNCTION getiPhase 1379 !------------------------------------------------------------------------------------------------------------------------------ 1380 CHARACTER(LEN=1) FUNCTION getPhase(tname, phases, iPhase) RESULT(phase) 1381 CHARACTER(LEN=*), INTENT(IN) :: tname 1382 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases 1383 INTEGER, OPTIONAL, INTENT(OUT) :: iPhase 1384 INTEGER :: ip 1385 phase = TRIM(strHead(strTail(tname, phases_sep, .TRUE.), '_', .TRUE.)) 1386 IF( PRESENT(phases)) ip = INDEX( phases, phase) 1387 IF(.NOT.PRESENT(phases)) ip = INDEX(known_phases, phase) 1388 IF(ip == 0) phase = 'g' 1389 IF(PRESENT(iPhase)) iPhase = ip 1390 END FUNCTION getPhase 1391 !------------------------------------------------------------------------------------------------------------------------------ 1392 1393 1394 !------------------------------------------------------------------------------------------------------------------------------ 1395 CHARACTER(LEN=maxlen) FUNCTION old2newName_1(oldName, iPhase) RESULT(newName) 1396 !--- Convert an old style name into a new one. 1397 ! Only usable with old style "traceur.def" files, in which only water isotopes are allowed. 1398 ! In these files, H2O descendants names are: H2O<phase>[_<isotope>][_<tag>], with: 1399 ! phase = v, l or i ; isotope = eau, HDO, O18, O17 or HTO. 1400 CHARACTER(LEN=*), INTENT(IN) :: oldName 1401 INTEGER, OPTIONAL, INTENT(OUT) :: iPhase 1402 CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:) 1403 INTEGER :: ix, ip, it, nt 1404 LOGICAL :: lerr 1405 newName = oldName 1406 IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase 1407 IF(oldName(1:MIN(3,LEN_TRIM(oldName))) /= 'H2O') RETURN !--- Not a water descendant 1408 lerr = strParse(oldName, '_', tmp, n=nt) 1409 ip = strIdx([('H2O'//old_phases(ip:ip), ip=1, nphases)], tmp(1)) !--- Phase index (/=0 if any) 1410 IF(PRESENT(iPhase)) iPhase = ip 1411 newName = addPhase('H2O', ip) !--- Water 1412 IF(nt == 1) RETURN !--- Water: finished 1413 ix = strIdx(oldH2OIso, tmp(2)) !--- Index in the known isotopes list 1414 IF(ix == 0) newName = addPhase(tmp(2), ip) !--- Not an isotope 1415 IF(ix /= 0) newName = addPhase(newH2OIso(ix), ip) !--- Isotope 1416 IF(nt == 3) newName = TRIM(newName)//'_'//TRIM(tmp(3)) !--- Tagging tracer 1417 END FUNCTION old2newName_1 1418 !------------------------------------------------------------------------------------------------------------------------------ 1419 FUNCTION old2newName_m(oldName, iPhase) RESULT(newName) 1420 CHARACTER(LEN=*), INTENT(IN) :: oldName(:) 1421 INTEGER, OPTIONAL, INTENT(OUT) :: iPhase 1422 CHARACTER(LEN=maxlen) :: newName(SIZE(oldName)) 1423 INTEGER :: i 1424 newName = [(old2newName_1(oldName(i), iPhase), i=1, SIZE(oldName))] 1425 END FUNCTION old2newName_m 1426 !------------------------------------------------------------------------------------------------------------------------------ 1427 1428 !------------------------------------------------------------------------------------------------------------------------------ 1429 CHARACTER(LEN=maxlen) FUNCTION new2oldName_1(newName, iPhase) RESULT(oldName) 1430 !--- Convert a new style name into an old one. 1431 ! Only convertable names are water descendants names H2O_<phase>, <isotope>_<phase>, <isotope>_<phase>_<tag>, with: 1432 ! phase = g, l or s ; isotope = H2[16]O, H[2]O, H2<[18]O, H2[17]O or H[3]O. 1433 CHARACTER(LEN=*), INTENT(IN) :: newName 1434 INTEGER, OPTIONAL, INTENT(OUT) :: iPhase 1435 INTEGER :: ix, ip, it, nt 1436 LOGICAL :: lH2O 1437 CHARACTER(LEN=maxlen) :: tag 1438 ix = strIdx([(addPhase('H2O',ip), ip=1, nphases)], newName) !--- Phase index for H2O_<phase> 1439 IF(ix /= 0) THEN; oldName = 'H2O'//old_phases(ix:ix); RETURN; END IF !--- H2O_<phase> case 1440 ix = strIdx(newH2OIso, strHead(newName, phases_sep, .TRUE.)) !--- Isotope index 1441 IF(ix == 0) THEN; oldName = newName; RETURN; END IF !--- Not a water descendant 1442 ip = getiPhase(newName) !--- Phase index 1443 oldName = TRIM(oldH2OIso(ix))//old_phases(ip:ip) !--- <isotope>_<phase> 1444 tag = strTail(delPhase(newName), TRIM(newH2OIso(ix))) !--- Get "_<tag>" if any 1445 IF(tag /= delPhase(newName) .AND. tag /= '') oldName = TRIM(oldName)//tag !--- Tagging tracer 1446 END FUNCTION new2oldName_1 1447 !------------------------------------------------------------------------------------------------------------------------------ 1448 FUNCTION new2oldName_m(newName, iPhase) RESULT(oldName) 1449 CHARACTER(LEN=*), INTENT(IN) :: newName(:) 1450 INTEGER, OPTIONAL, INTENT(OUT) :: iPhase 1451 CHARACTER(LEN=maxlen) :: oldName(SIZE(newName)) 1452 INTEGER :: i 1453 oldName = [(new2oldName_1(newName(i), iPhase), i=1, SIZE(newName))] 1454 END FUNCTION new2oldName_m 1455 !------------------------------------------------------------------------------------------------------------------------------ 1456 1314 1457 1315 1458 !============================================================================================================================== -
LMDZ6/trunk/libf/misc/strings_mod.F90
r4069 r4120 26 26 ! horzcat_d1, horzcat_dm, 27 27 horzcat_sm, horzcat_im, horzcat_rm; END INTERFACE cat 28 INTERFACE find; MODULE PROCEDUREstrFind, find_int, find_boo; END INTERFACE find28 INTERFACE find; MODULE PROCEDURE strFind, find_int, find_boo; END INTERFACE find 29 29 INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers 30 30 INTERFACE reduceExpr; MODULE PROCEDURE reduceExpr_1, reduceExpr_m; END INTERFACE reduceExpr … … 105 105 LOGICAL, OPTIONAL, INTENT(IN) :: ll 106 106 INTEGER, OPTIONAL, INTENT(IN) :: unit 107 CHARACTER(LEN=maxlen) :: subn 107 108 INTEGER :: unt 109 subn = ''; IF(PRESENT(modname)) subn = modname 108 110 IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF 109 111 unt = lunout; IF(PRESENT(unit)) unt = unit 110 IF(PRESENT(modname)) THEN 111 WRITE(unt,'(a)') TRIM(modname)//': '//str !--- Routine name provided 112 ELSE 113 WRITE(unt,'(a)') str !--- Simple message 114 END IF 112 IF(subn == '') WRITE(unt,'(a)') str !--- Simple message 113 IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str !--- Routine name provided 115 114 END SUBROUTINE msg_1 116 115 !============================================================================================================================== … … 123 122 INTEGER, OPTIONAL, INTENT(IN) :: nmax 124 123 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) 124 CHARACTER(LEN=maxlen) :: subn 125 125 INTEGER :: unt, nmx, k 126 126 LOGICAL :: l 127 subn = ''; IF(PRESENT(modname)) subn = modname 127 128 l = .TRUE.; IF(PRESENT(ll)) l = ll 128 129 unt = lunout; IF(PRESENT(unit)) unt = unit 129 130 nmx = 128; IF(PRESENT(nmax)) nmx = nmax 130 131 s = strStackm(str, ', ', nmx) 131 IF(PRESENT(modname)) THEN 132 DO k=1,SIZE(s); CALL msg_1(s(k), modname, l, unt); END DO 133 ELSE 134 DO k=1,SIZE(s); CALL msg_1(s(k), ll=l, unit=unt); END DO 135 END IF 132 DO k=1,SIZE(s); CALL msg_1(s(k), subn, l, unt); END DO 136 133 END SUBROUTINE msg_m 137 134 !============================================================================================================================== … … 141 138 LOGICAL, OPTIONAL, INTENT(IN) :: ll 142 139 INTEGER, OPTIONAL, INTENT(IN) :: unit 140 CHARACTER(LEN=maxlen) :: subn 143 141 INTEGER :: unt 142 subn = ''; IF(PRESENT(modname)) subn = modname 144 143 l = .TRUE.; IF(PRESENT(ll)) l = ll 145 144 unt = lunout; IF(PRESENT(unit)) unt = unit 146 IF(PRESENT(modname)) THEN 147 CALL msg_1(str, modname, l, unt) 148 ELSE 149 CALL msg_1(str, ll=l, unit=unt) 150 END IF 145 CALL msg_1(str, subn, l, unt) 151 146 END FUNCTION fmsg_1 152 147 !============================================================================================================================== … … 157 152 INTEGER, OPTIONAL, INTENT(IN) :: unit 158 153 INTEGER, OPTIONAL, INTENT(IN) :: nmax 154 CHARACTER(LEN=maxlen) :: subn 159 155 INTEGER :: unt, nmx 156 subn = ''; IF(PRESENT(modname)) subn = modname 160 157 l = .TRUE.; IF(PRESENT(ll)) l = ll 161 158 unt = lunout; IF(PRESENT(unit)) unt = unit 162 159 nmx = 128; IF(PRESENT(nmax)) nmx = nmax 163 IF(PRESENT(modname)) THEN 164 CALL msg_m(str, modname, l, unt, nmx) 165 ELSE 166 CALL msg_m(str, ll=l, unit=unt, nmax=nmx) 167 END IF 160 CALL msg_m(str, subn, l, unt, nmx) 168 161 END FUNCTION fmsg_m 169 162 !============================================================================================================================== … … 178 171 out = str 179 172 DO k=1,LEN_TRIM(str) 180 IF(str(k:k)>='A' .OR.str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)173 IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32) 181 174 END DO 182 175 END FUNCTION strLower … … 187 180 out = str 188 181 DO k=1,LEN_TRIM(str) 189 IF(str(k:k)>='a' .OR.str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)182 IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32) 190 183 END DO 191 184 END FUNCTION strUpper … … 222 215 lf = .FALSE.; IF(PRESENT(lFirst)) lf=lFirst 223 216 IF(PRESENT(sep)) THEN 224 out = [(strHead_1(str(k), sep,.NOT.lf),k=1, SIZE(str))]217 out = [(strHead_1(str(k), sep, lf), k=1, SIZE(str))] 225 218 ELSE 226 out = [(strHead_1(str(k), lFirst=.NOT.lf), k=1, SIZE(str))]219 out = [(strHead_1(str(k), lFirst=lf), k=1, SIZE(str))] 227 220 END IF 228 221 END FUNCTION strHead_m … … 230 223 !=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ================ 231 224 !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ 232 !=== * str Head(..,.FALSE.) = 'b_c'${str#*$sep} ================233 !=== * str Head(..,.TRUE.) = 'c'${str##*$sep} ================225 !=== * strTail(..,.FALSE.) = 'c' ${str#*$sep} ================ 226 !=== * strTail(..,.TRUE.) = 'b_c' ${str##*$sep} ================ 234 227 !============================================================================================================================== 235 228 CHARACTER(LEN=maxlen) FUNCTION strTail_1(str,sep,lFirst) RESULT(out) … … 256 249 lf = .FALSE.; IF(PRESENT(lFirst)) lf=lFirst 257 250 IF(PRESENT(sep)) THEN 258 out = [(strTail_1(str(k), sep,.NOT.lf),k=1, SIZE(str))]251 out = [(strTail_1(str(k), sep, lf), k=1, SIZE(str))] 259 252 ELSE 260 out = [(strTail_1(str(k), lFirst=.NOT.lf), k=1, SIZE(str))]253 out = [(strTail_1(str(k), lFirst=lf), k=1, SIZE(str))] 261 254 END IF 262 255 END FUNCTION strTail_m … … 861 854 !=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display. 862 855 !============================================================================================================================== 863 LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nmax, unit ) RESULT(lerr)856 LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nmax, unit, sub) RESULT(lerr) 864 857 CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r 865 858 CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN) … … 870 863 INTEGER, OPTIONAL, INTENT(IN) :: nmax !--- Display less than "nrow" rows 871 864 INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) 865 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name 872 866 873 867 CHARACTER(LEN=2048) :: row 874 CHARACTER(LEN=maxlen) :: rFm, el 868 CHARACTER(LEN=maxlen) :: rFm, el, subn 875 869 CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) 876 870 CHARACTER(LEN=1) :: s1, sp … … 881 875 LOGICAL :: ls, li, lr 882 876 883 ! modname = 'dispTable' 877 subn = ''; IF(PRESENT(sub)) subn = sub 884 878 rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals 885 879 unt = lunout; IF(PRESENT(unit)) unt = unit !--- Specified output unit … … 890 884 891 885 !--- CHECK ARGUMENTS COHERENCE 892 lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', ll=lerr)) RETURN893 IF(ls) THEN ; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)894 lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)895 END IF 896 IF(li) THEN ; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2)897 lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2)898 END IF 899 IF(lr) THEN ; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2)900 lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)901 END IF 902 IF(fmsg('string "pattern" length and arguments number mismatch', ll=lerr)) RETURN903 lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN904 lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN905 lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', ll=lerr)) RETURN906 lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', ll=lerr)) RETURN886 lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', subn, lerr)) RETURN 887 IF(ls) THEN 888 ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2) 889 END IF 890 IF(li) THEN 891 ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2) 892 END IF 893 IF(lr) THEN 894 nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2) 895 END IF 896 IF(fmsg('string "pattern" length and arguments number mismatch', subn, lerr)) RETURN 897 lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN 898 lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN 899 lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', subn, lerr)) RETURN 900 lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', subn, lerr)) RETURN 907 901 nrow = MAX(ns,ni,nr)+1 908 902 nmx = nrow; IF(PRESENT(nmax)) nmx = MIN(nmx,nmax+1) … … 931 925 END DO 932 926 nr = LEN_TRIM(row)-1 !--- Final separator removed 933 CALL msg(row(1:nr), unit=unt)927 CALL msg(row(1:nr), subn, unit=unt) 934 928 IF(ir /= 1) CYCLE !--- Titles are underlined 935 929 row=''; DO ic=1,ncol; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO 936 CALL msg(row(1:LEN_TRIM(row)-1), unit=unt)930 CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt) 937 931 END DO 938 932 -
LMDZ6/trunk/libf/misc/trac_types_mod.F90
r4071 r4120 20 20 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag') 21 21 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid) 22 CHARACTER(LEN=maxlen) :: component 22 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca) 23 23 INTEGER :: iadv = 10 !--- Advection scheme used 24 24 INTEGER :: iGeneration = -1 !--- Generation number (>=0) … … 47 47 INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers 48 48 INTEGER :: nphas = 0 !--- Number phases 49 INTEGER, ALLOCATABLE :: i TraPha(:,:) !--- Idx in "trac(1:niso)" = f(name(1:ntiso)),phas)50 !--- "i TraPha" former name: "iqiso"51 INTEGER, ALLOCATABLE :: i ZonIso(:,:)!--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso))52 !--- "i ZonIso" former name: "index_trac"49 INTEGER, ALLOCATABLE :: iqTraPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 50 !--- "iqTraPha" former name: "iqiso" 51 INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso)) 52 !--- "itZonIso" former name: "index_trac" 53 53 END TYPE isot_type 54 54 -
LMDZ6/trunk/libf/phylmd/infotrac_phy.F90
r4071 r4120 4 4 MODULE infotrac_phy 5 5 6 ! Infotrac for physics; for now contains the same information as infotrac for 7 ! the dynamics (could be further cleaned) and is initialized using values 8 ! provided by the dynamics 9 10 USE readTracFiles_mod, ONLY: trac_type, maxlen, delPhase 11 12 ! nqtot : total number of tracers and higher order of moment, water vapor and liquid included 13 INTEGER, SAVE :: nqtot 14 !$OMP THREADPRIVATE(nqtot) 15 16 !CR: on ajoute le nombre de traceurs de l eau 17 INTEGER, SAVE :: nqo 18 !$OMP THREADPRIVATE(nqo) 19 20 ! nbtr : number of tracers not including higher order of moment or water vapor or liquid 21 ! number of tracers used in the physics 22 INTEGER, SAVE :: nbtr 23 !$OMP THREADPRIVATE(nbtr) 24 25 INTEGER, SAVE :: nqtottr 26 !$OMP THREADPRIVATE(nqtottr) 27 28 ! ThL : number of CO2 tracers ModThL 29 INTEGER, SAVE :: nqCO2 30 !$OMP THREADPRIVATE(nqCO2) 6 USE strings_mod, ONLY: msg, maxlen, strStack, strHead, strIdx, int2str 7 USE readTracFiles_mod, ONLY: trac_type, isot_type, keys_type, delPhase, getKey, tnom_iso => newH2OIso 8 9 IMPLICIT NONE 10 11 PRIVATE 12 13 !=== FOR TRACERS: 14 PUBLIC :: init_infotrac_phy !--- Initialization of the tracers 15 PUBLIC :: tracers, type_trac !--- Full tracers database, tracers type keyword 16 PUBLIC :: nqtot, nbtr, nqo, nqCO2, nqtottr !--- Main dimensions 17 PUBLIC :: conv_flg, pbl_flg, solsym !--- Convection & boundary layer activation keys 18 19 !=== FOR ISOTOPES: General 20 PUBLIC :: isotopes, nbIso !--- Derived type, full isotopes families database + nb of families 21 PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index 22 !=== FOR ISOTOPES: Specific to water 23 PUBLIC :: iH2O !--- H2O isotopes index 24 !=== FOR ISOTOPES: Depending on the selected isotopes family 25 PUBLIC :: isotope, isoKeys !--- Selected isotopes database + associated keys (cf. getKey) 26 PUBLIC :: isoName, isoZone, isoPhas !--- Isotopes and tagging zones names, phases 27 PUBLIC :: niso, nzone, nphas, ntiso !--- " " numbers + isotopes & tagging tracers number 28 PUBLIC :: itZonIso !--- iq = function(tagging zone idx, isotope idx) 29 PUBLIC :: iqTraPha !--- idx of tagging tracer in iName = function(isotope idx, phase idx) 30 PUBLIC :: isoCheck !--- Run isotopes checking routines 31 !=== FOR BOTH TRACERS AND ISOTOPES 32 PUBLIC :: getKey !--- Get a key from "tracers" or "isotope" 33 34 PUBLIC :: ntraciso, ntraceurs_zone, indnum_fn_num, use_iso, index_trac, iqiso 35 PUBLIC :: niso_possibles, ok_isotrac, ok_isotopes, ok_iso_verif 36 37 INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect 38 39 !=== CONVENTIONS FOR TRACERS NUMBERS: 40 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 41 ! | water in different | water tagging | water isotopes | other tracers | additional tracers moments | 42 ! | phases: H2O_[gls] | isotopes | | | for higher order schemes | 43 ! |--------------------+-----------------------+-----------------+---------------+----------------------------| 44 ! | | | | | | 45 ! |<-- nqo -->|<-- nqo*niso* nzone -->|<-- nqo*niso -->|<-- nbtr -->|<-- (nmom) -->| 46 ! | | | | 47 ! | |<-- nqo*niso*(nzone+1) = nqo*ntiso -->|<-- nqtottr = nbtr + nmom -->| 48 ! | = nqtot - nqo*(ntiso+1) | 49 ! | | 50 ! |<-- nqtrue = nbtr + nqo*(ntiso+1) -->| | 51 ! | | 52 ! |<-- nqtot = nqtrue + nmom -->| 53 ! | | 54 ! |-----------------------------------------------------------------------------------------------------------| 55 ! NOTES FOR THIS TABLE: 56 ! * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)%parent == 'H2O'), 57 ! since water is so far the sole tracers family, except passive CO2, removed from the main tracers table. 58 ! * For water, "nqo" is equal to the more general field "isotopes(ip)%nphas". 59 ! * "niso", "nzone", "ntiso", "nphas" are defined for other isotopic tracers families, if any. 60 ! 61 !=== DERIVED TYPE EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot) 62 ! Each entry is accessible using "%" sign. 63 ! |-------------+------------------------------------------------------+-------------+------------------------+ 64 ! | entry | Meaning | Former name | Possible values | 65 ! |-------------+------------------------------------------------------+-------------+------------------------+ 66 ! | name | Name (short) | tname | | 67 ! | gen0Name | Name of the 1st generation ancestor | / | | 68 ! | parent | Name of the parent | / | | 69 ! | longName | Long name (with adv. scheme suffix) for outputs | ttext | | 70 ! | type | Type (so far: tracer or tag) | / | tracer,tag | 71 ! | phase | Phases list ("g"as / "l"iquid / "s"olid) | / | [g][l][s] | 72 ! | component | Name(s) of the merged/cumulated section(s) | / | coma-separated names | 73 ! | iadv | Advection scheme number | iadv | 1-20,30 exc. 3-9,15,19 | 74 ! | iGeneration | Generation (>=1) | / | | 75 ! | isAdvected | advected tracers flag (.TRUE. if iadv >= 0) | / | nqtrue .TRUE. values | 76 ! | isInPhysics | tracers not extracted from the main table in physics | / | nqtottr .TRUE. values | 77 ! | iqParent | Index of the parent tracer | iqpere | 1:nqtot | 78 ! | iqDescen | Indexes of the childs (all generations) | iqfils | 1:nqtot | 79 ! | nqDescen | Number of the descendants (all generations) | nqdesc | 1:nqtot | 80 ! | nqChilds | Number of childs (1st generation only) | nqfils | 1:nqtot | 81 ! | iso_iGroup | Isotopes group index in isotopes(:) | / | 1:nbIso | 82 ! | iso_iName | Isotope name index in isotopes(iso_iGroup)%trac(:) | iso_indnum | 1:niso | 83 ! | iso_iZone | Isotope zone index in isotopes(iso_iGroup)%zone(:) | zone_num | 1:nzone | 84 ! | iso_iPhas | Isotope phase index in isotopes(iso_iGroup)%phas(:) | phase_num | 1:nphas | 85 ! | keys | key/val pairs accessible with "getKey" routine | / | | 86 ! +-------------+------------------------------------------------------+-------------+------------------------+ 87 ! 88 !=== DERIVED TYPE EMBEDDING MOST OF THE ISOTOPES-RELATED QUANTITIES (LENGTH: nbIso, NUMBER OF ISOTOPES FAMILIES) 89 ! Each entry is accessible using "%" sign. 90 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 91 ! | entry | length | Meaning | Former name | Possible values | 92 ! |-----------------+--------------------------------------------------+--------------------+-----------------+ 93 ! | parent | Parent tracer (isotopes family name) | | | 94 ! | keys | niso | Isotopes keys/values pairs list + number | | | 95 ! | trac | ntiso | Isotopes + tagging tracers list + number | / | ntraciso | | 96 ! | zone | nzone | Geographic tagging zones list + number | / | ntraceurs_zone | | 97 ! | phase | nphas | Phases list + number | | [g][l][s], 1:3 | 98 ! | iqTraPha | Index in "qx" = f(name(1:ntiso)),phas) | iqiso | 1:nqtot | 99 ! | itZonIso | Index in "trac(1:ntiso)"= f(zone, name(1:niso)) | index_trac | 1:ntiso | 100 ! +-----------------+--------------------------------------------------+--------------------+-----------------+ 101 102 !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES 103 INTEGER, SAVE :: nqtot, & !--- Tracers nb in dynamics (incl. higher moments + H2O) 104 nbtr, & !--- Tracers nb in physics (excl. higher moments + H2O) 105 nqo, & !--- Number of water phases 106 nbIso, & !--- Number of available isotopes family 107 nqtottr, & !--- Number of tracers passed to phytrac (TO BE DELETED ?) 108 nqCO2 !--- Number of tracers of CO2 (ThL) 109 CHARACTER(LEN=maxlen), SAVE :: type_trac !--- Keyword for tracers type 110 !$OMP THREADPRIVATE(nqtot, nbtr, nqo, nbIso, nqtottr, nqCO2, type_trac) 111 112 !=== DERIVED TYPES EMBEDDING MOST INFORMATIONS ABOUT TRACERS AND ISOTOPES FAMILIES 113 TYPE(trac_type), TARGET, SAVE, ALLOCATABLE :: tracers(:) !=== TRACERS DESCRIPTORS VECTOR 114 TYPE(isot_type), TARGET, SAVE, ALLOCATABLE :: isotopes(:) !=== ISOTOPES PARAMETERS VECTOR 115 !$OMP THREADPRIVATE(tracers, isotopes) 116 117 !=== ALIASES FOR CURRENTLY SELECTED ISOTOPES FAMILY OF VARIABLES EMBEDDED IN THE VECTOR "isotopes" 118 TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR 119 INTEGER, SAVE :: ixIso, iH2O !--- Index of the selected isotopes family and H2O family 120 LOGICAL, SAVE, POINTER :: isoCheck !--- Flag to trigger the checking routines 121 TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName) 122 CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY 123 isoZone(:), & !--- TAGGING ZONES FOR THE CURRENTLY SELECTED FAMILY 124 isoPhas !--- USED PHASES FOR THE CURRENTLY SELECTED FAMILY 125 INTEGER, SAVE, POINTER :: niso, nzone, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES 126 nphas, ntiso, & !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS 127 itZonIso(:,:), & !--- INDEX IN "isoTrac" AS f(tagging zone idx, isotope idx) 128 iqTraPha(:,:) !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) 129 !$OMP THREADPRIVATE(isotope, ixIso,iH2O, isoCheck, isoKeys, isoName,isoZone,isoPhas, niso,nzone,nphas,ntiso, itZonIso,iqTraPha) 130 131 !=== VARIABLES FOR ISOTOPES INITIALIZATION AND FOR INCA 132 INTEGER, SAVE, ALLOCATABLE ::conv_flg(:), & !--- Convection activation ; needed for INCA (nbtr) 133 pbl_flg(:) !--- Boundary layer activation ; needed for INCA (nbtr) 134 CHARACTER(LEN=8), SAVE, ALLOCATABLE :: solsym(:) 135 !$OMP THREADPRIVATE(conv_flg, pbl_flg, solsym) 136 137 !--- Aliases for older names + quantities to be removed (will be replaced by:) 138 INTEGER, POINTER, SAVE :: ntraciso, ntraceurs_zone !--- -> ntiso, nzone 139 !$OMP THREADPRIVATE (ntraciso, ntraceurs_zone) 140 INTEGER, POINTER, SAVE :: index_trac(:,:), iqiso(:,:) !--- -> itZonIso, iqTraPha 141 !$OMP THREADPRIVATE (index_trac, iqiso) 142 INTEGER, SAVE :: niso_possibles !--- suppressed (use effective niso instead) 143 !$OMP THREADPRIVATE(niso_possibles) 144 LOGICAL, SAVE :: ok_isotopes, ok_iso_verif, ok_isotrac !--- -> niso>0, isoCheck, nzone>0 145 !$OMP THREADPRIVATE(ok_isotopes, ok_iso_verif, ok_isotrac) 146 LOGICAL, SAVE, ALLOCATABLE :: use_iso(:) !--- suppressed 147 !$OMP THREADPRIVATE (use_iso) 148 INTEGER, SAVE, ALLOCATABLE :: indnum_fn_num(:) 149 !$OMP THREADPRIVATE (indnum_fn_num) 31 150 32 151 #ifdef CPP_StratAer … … 38 157 #endif 39 158 40 ! Tracers parameters41 TYPE(trac_type), TARGET, ALLOCATABLE, SAVE :: tracers(:)42 !$OMP THREADPRIVATE(tracers)43 44 ! conv_flg(it)=0 : convection desactivated for tracer number it45 INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg46 !$OMP THREADPRIVATE(conv_flg)47 48 ! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it49 INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg50 !$OMP THREADPRIVATE(pbl_flg)51 52 CHARACTER(len=4),SAVE :: type_trac53 !$OMP THREADPRIVATE(type_trac)54 CHARACTER(len=8),DIMENSION(:),ALLOCATABLE, SAVE :: solsym55 !$OMP THREADPRIVATE(solsym)56 57 ! CRisi: cas particulier des isotopes58 LOGICAL,SAVE :: ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso59 !$OMP THREADPRIVATE(ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso)60 INTEGER :: niso_possibles61 PARAMETER ( niso_possibles=5)62 real, DIMENSION (niso_possibles),SAVE :: tnat,alpha_ideal63 !$OMP THREADPRIVATE(tnat,alpha_ideal)64 LOGICAL, DIMENSION(niso_possibles),SAVE :: use_iso65 !$OMP THREADPRIVATE(use_iso)66 INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: iqiso ! donne indice iq en fn de (ixt,phase)67 !$OMP THREADPRIVATE(iqiso)68 INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iso_indnum ! donne numéro iso entre 1 et niso effectif en fn de nqtot69 !$OMP THREADPRIVATE(iso_indnum)70 INTEGER, DIMENSION(niso_possibles), SAVE :: indnum_fn_num ! donne indice entre entre 1 et niso en fonction du numéro d isotope entre 1 et niso_possibles71 !$OMP THREADPRIVATE(indnum_fn_num)72 INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: index_trac ! numéro ixt en fn izone, indnum entre 1 et niso73 !$OMP THREADPRIVATE(index_trac)74 INTEGER,SAVE :: niso,ntraceurs_zone,ntraciso75 !$OMP THREADPRIVATE(niso,ntraceurs_zone,ntraciso)76 77 159 CONTAINS 78 160 79 SUBROUTINE init_infotrac_phy(nqtot_,nqo_,nbtr_,nqtottr_,nqCO2_,tracers_,type_trac_,& 80 conv_flg_,pbl_flg_,solsym_,& 81 ok_isotopes_,ok_iso_verif_,ok_isotrac_,& 82 ok_init_iso_,niso_possibles_,tnat_,& 83 alpha_ideal_,use_iso_,iqiso_,iso_indnum_,& 84 indnum_fn_num_,index_trac_,& 85 niso_,ntraceurs_zone_,ntraciso_) 86 87 ! transfer information on tracers from dynamics to physics 88 USE print_control_mod, ONLY: prt_level, lunout 89 IMPLICIT NONE 90 91 INTEGER,INTENT(IN) :: nqtot_ 92 INTEGER,INTENT(IN) :: nqo_ 93 INTEGER,INTENT(IN) :: nbtr_ 94 INTEGER,INTENT(IN) :: nqtottr_ 95 INTEGER,INTENT(IN) :: nqCO2_ 96 TYPE(trac_type), INTENT(IN) :: tracers_(nqtot_) ! tracers descriptors 97 CHARACTER(len=*),INTENT(IN) :: type_trac_ 98 INTEGER,INTENT(IN) :: conv_flg_(nbtr_) 99 INTEGER,INTENT(IN) :: pbl_flg_(nbtr_) 100 CHARACTER(len=*),INTENT(IN) :: solsym_(nbtr_) 101 ! Isotopes: 102 LOGICAL,INTENT(IN) :: ok_isotopes_ 103 LOGICAL,INTENT(IN) :: ok_iso_verif_ 104 LOGICAL,INTENT(IN) :: ok_isotrac_ 105 LOGICAL,INTENT(IN) :: ok_init_iso_ 106 INTEGER,INTENT(IN) :: niso_possibles_ 107 REAL,INTENT(IN) :: tnat_(niso_possibles_) 108 REAL,INTENT(IN) :: alpha_ideal_(niso_possibles_) 109 LOGICAL,INTENT(IN) :: use_iso_(niso_possibles_) 110 INTEGER,INTENT(IN) :: iqiso_(ntraciso_,nqo_) 111 INTEGER,INTENT(IN) :: iso_indnum_(nqtot_) 112 INTEGER,INTENT(IN) :: indnum_fn_num_(niso_possibles_) 113 INTEGER,INTENT(IN) :: index_trac_(ntraceurs_zone_,niso_) 114 INTEGER,INTENT(IN) :: niso_ 115 INTEGER,INTENT(IN) :: ntraceurs_zone_ 116 INTEGER,INTENT(IN) :: ntraciso_ 117 118 INTEGER :: iq, itr 119 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 120 CHARACTER(LEN=maxlen) :: modname="init_infotrac_phy" 121 122 nqtot=nqtot_ 123 nqo=nqo_ 124 nbtr=nbtr_ 125 nqCO2=nqCO2_ 126 nqtottr=nqtottr_ 127 ALLOCATE(tracers(nqtot)); tracers(:) = tracers_(:) 161 SUBROUTINE init_infotrac_phy(type_trac_, tracers_, isotopes_, nqtottr_, nqCO2_, pbl_flg_, conv_flg_, solsym_) 162 163 USE print_control_mod, ONLY: prt_level, lunout 164 165 IMPLICIT NONE 166 CHARACTER(LEN=*),INTENT(IN) :: type_trac_ 167 TYPE(trac_type), INTENT(IN) :: tracers_(:) 168 TYPE(isot_type), INTENT(IN) :: isotopes_(:) 169 INTEGER, INTENT(IN) :: nqtottr_ 170 INTEGER, INTENT(IN) :: nqCO2_ 171 INTEGER, INTENT(IN) :: conv_flg_(:) 172 INTEGER, INTENT(IN) :: pbl_flg_(:) 173 CHARACTER(LEN=*),INTENT(IN) :: solsym_(:) 174 175 INTEGER :: iq, ixt 128 176 #ifdef CPP_StratAer 129 IF (type_trac == 'coag') THEN 177 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 178 #endif 179 CHARACTER(LEN=maxlen) :: modname="init_infotrac_phy" 180 181 type_trac = type_trac_ 182 tracers = tracers_ 183 isotopes = isotopes_ 184 nqtottr = nqtottr_ 185 nqCO2 = nqCO2_ 186 pbl_flg = pbl_flg_ 187 conv_flg = conv_flg_ 188 solsym = solsym_ 189 nqtot = SIZE(tracers_) 190 nqo = COUNT(delPhase(tracers%name)=='H2O' .AND. tracers%iGeneration==0) 191 nbtr = SIZE(conv_flg) 192 nbIso = SIZE(isotopes_) 193 194 !=== Determine selected isotopes class related quantities: 195 ! ixIso, isotope, niso,isoKeys, ntiso,isoName, nzone,isoZone, nphas,isoPhas, itZonIso, iqTraPha, isoCheck 196 IF(.NOT.isoSelect('H2O')) iH2O = ixIso 197 IF(prt_level > 1) THEN 198 CALL msg('nqtot = '//TRIM(int2str(nqtot)), modname) 199 CALL msg('nbtr = '//TRIM(int2str(nbtr )), modname) 200 CALL msg('nqo = '//TRIM(int2str(nqo )), modname) 201 CALL msg('niso = '//TRIM(int2str(niso )), modname) 202 CALL msg('ntiso = '//TRIM(int2str(ntiso)), modname) 203 CALL msg('nqtottr = '//TRIM(int2str(nqtottr)), modname) 204 CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname) 205 END IF 206 207 #ifdef CPP_StratAer 208 IF (type_trac == 'coag') THEN 130 209 nbtr_bin = COUNT([(tracers(iq)%name(1:3)=='BIN', iq=1, nqtot)]) 131 210 nbtr_sulgas = COUNT([(tracers(iq)%name(1:3)=='GAS', iq=1, nqtot)]) … … 136 215 id_H2SO4_strat = strIdx(tnames, 'GASH2SO4') 137 216 id_TEST_strat = strIdx(tnames, 'GASTEST' ) 138 WRITE(lunout,*)'nbtr_bin =', nbtr_bin 139 WRITE(lunout,*)'nbtr_sulgas =', nbtr_sulgas 140 WRITE(lunout,*)'id_BIN01_strat =', id_BIN01_strat 141 WRITE(lunout,*)'id_OCS_strat =', id_OCS_strat 142 WRITE(lunout,*)'id_SO2_strat =', id_SO2_strat 143 WRITE(lunout,*)'id_H2SO4_strat =', id_H2SO4_strat 144 WRITE(lunout,*)'id_TEST_strat =', id_TEST_strat 145 END IF 146 #endif 147 type_trac = type_trac_ 148 ALLOCATE(conv_flg(nbtr)) 149 conv_flg(:)=conv_flg_(:) 150 ALLOCATE(pbl_flg(nbtr)) 151 pbl_flg(:)=pbl_flg_(:) 152 ALLOCATE(solsym(nbtr)) 153 solsym(:)=solsym_(:) 154 155 IF(prt_level.ge.1) THEN 156 write(lunout,*) TRIM(modname)//": nqtot,nqo,nbtr,nqCO2",nqtot,nqo,nbtr,nqCO2 157 ENDIF 158 159 ! Isotopes: 160 161 ! First check that the "niso_possibles" has the correct value 162 IF (niso_possibles.ne.niso_possibles_) THEN 163 CALL abort_physic(modname,& 164 "wrong value for parameter niso_possibles in infotrac_phy",1) 165 ENDIF 166 167 ok_isotopes=ok_isotopes_ 168 ok_iso_verif=ok_iso_verif_ 169 ok_isotrac=ok_isotrac_ 170 ok_init_iso=ok_init_iso_ 171 172 niso=niso_ 173 ntraceurs_zone=ntraceurs_zone_ 174 ntraciso=ntraciso_ 175 176 IF (ok_isotopes) THEN 177 tnat(:)=tnat_(:) 178 alpha_ideal(:)=alpha_ideal_(:) 179 use_iso(:)=use_iso_(:) 180 181 ALLOCATE(iqiso(ntraciso,nqo)) 182 iqiso(:,:)=iqiso_(:,:) 183 ALLOCATE(iso_indnum(nqtot)) 184 iso_indnum(:)=iso_indnum_(:) 185 186 indnum_fn_num(:)=indnum_fn_num_(:) 187 188 ALLOCATE(index_trac(ntraceurs_zone,niso)) 189 index_trac(:,:)=index_trac_(:,:) 190 ENDIF ! of IF(ok_isotopes) 191 192 WRITE(*,*) 'infotrac_phy 207: nqtottr=',nqtottr 193 WRITE(*,*) 'ntraciso,niso=',ntraciso,niso 217 CALL msg('nbtr_bin ='//TRIM(int2str(nbtr_bin )), modname) 218 CALL msg('nbtr_sulgas ='//TRIM(int2str(nbtr_sulgas )), modname) 219 CALL msg('id_BIN01_strat ='//TRIM(int2str(id_BIN01_strat)), modname) 220 CALL msg('id_OCS_strat ='//TRIM(int2str(id_OCS_strat )), modname) 221 CALL msg('id_SO2_strat ='//TRIM(int2str(id_SO2_strat )), modname) 222 CALL msg('id_H2SO4_strat ='//TRIM(int2str(id_H2SO4_strat)), modname) 223 CALL msg('id_TEST_strat ='//TRIM(int2str(id_TEST_strat )), modname) 224 END IF 225 #endif 226 227 !--- Isotopic quantities (to be removed soon) 228 ntraciso => ntiso 229 ntraceurs_zone => nzone 230 iqiso => iqTraPha 231 index_trac => itZonIso 232 ok_isotopes = niso > 0 233 ok_isotrac = nzone > 0 234 ok_iso_verif = isoCheck 235 niso_possibles = SIZE(tnom_iso) 236 indnum_fn_num = [(strIdx(isotope%keys(:)%name, tnom_iso(ixt)), ixt=1, niso_possibles)] 237 use_iso = indnum_fn_num /= 0 194 238 #ifdef ISOVERIF 195 ! DC: the "1" will be replaced by iH2O (H2O isotopes group index) 196 WRITE(*,*) 'iso_iName=',PACK(tracers(:)%iso_iName, MASK=tracers(:)%iso_iGroup==1) 197 #endif 198 199 END SUBROUTINE init_infotrac_phy 239 CALL msg('iso_iName = '//strStack(int2str(PACK(tracers(:)%iso_iName, MASK=tracers(:)%iso_iGroup==iH2O))), modname) 240 #endif 241 242 END SUBROUTINE init_infotrac_phy 243 244 245 !============================================================================================================================== 246 !=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED 247 ! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call). 248 !============================================================================================================================== 249 LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr) 250 IMPLICIT NONE 251 CHARACTER(LEN=*), INTENT(IN) :: iName 252 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 253 INTEGER :: iIso 254 LOGICAL :: lV 255 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 256 iIso = strIdx(isotopes(:)%parent, iName) 257 lerr = iIso == 0 258 CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lerr .AND. lV) 259 IF(lerr) RETURN 260 lerr = isoSelectByIndex(iIso, lV) 261 END FUNCTION isoSelectByName 262 !============================================================================================================================== 263 LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr) 264 IMPLICIT NONE 265 INTEGER, INTENT(IN) :: iIso 266 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 267 LOGICAL :: lv 268 lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose 269 lerr = .FALSE. 270 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK 271 lerr = iIso<=0 .OR. iIso>nbIso 272 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '//TRIM(int2str(nbIso))//'"',& 273 ll=lerr .AND. lV) 274 IF(lerr) RETURN 275 ixIso = iIso !--- Update currently selected family index 276 isotope => isotopes(ixIso) !--- Select corresponding component 277 isoKeys => isotope%keys; niso => isotope%niso 278 isoName => isotope%trac; ntiso => isotope%ntiso 279 isoZone => isotope%zone; nzone => isotope%nzone 280 isoPhas => isotope%phase; nphas => isotope%nphas 281 itZonIso => isotope%itZonIso; isoCheck => isotope%check 282 iqTraPha => isotope%iqTraPha 283 END FUNCTION isoSelectByIndex 284 !============================================================================================================================== 285 200 286 201 287 END MODULE infotrac_phy -
LMDZ6/trunk/libf/phylmd/phys_output_mod.F90
r4089 r4120 35 35 USE iophy 36 36 USE dimphy 37 USE infotrac_phy, ONLY: nqtot, tracers, type_trac, niso, ntraciso, maxlen 37 USE infotrac_phy, ONLY: nqtot, tracers, type_trac, niso, ntraciso 38 USE strings_mod, ONLY: maxlen 38 39 USE ioipsl 39 40 USE phys_cal_mod, only : hour, calend -
LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90
r4109 r4120 25 25 26 26 USE dimphy, ONLY: klon, klev, klevp1 27 USE infotrac_phy, ONLY: nbtr, nqtot, nqo, type_trac, tracers, niso, ntraciso , maxlen27 USE infotrac_phy, ONLY: nbtr, nqtot, nqo, type_trac, tracers, niso, ntraciso 28 28 USE strings_mod, ONLY: maxlen 29 29 USE mod_phys_lmdz_para, ONLY: is_north_pole_phy,is_south_pole_phy -
LMDZ6/trunk/libf/phylmd/physiq_mod.F90
r4114 r4120 1294 1294 IF ((iflag_ice_thermo.gt.0).and.(nqo==2)) THEN 1295 1295 WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', & 1296 '(H2O v, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.'1296 '(H2O_g, H2O_l, H2O_s) but nqo=', nqo, '. Might as well stop here.' 1297 1297 abort_message='see above' 1298 1298 CALL abort_physic(modname,abort_message,1) … … 1307 1307 IF (ok_ice_sursat.AND.(nqo.NE.4)) THEN 1308 1308 WRITE (lunout, *) ' ok_ice_sursat=y requires 4 H2O tracers ', & 1309 '(H2O v, H2Ol, H2Oi, H2Or) but nqo=', nqo, '. Might as well stop here.'1309 '(H2O_g, H2O_l, H2O_s, H2O_r) but nqo=', nqo, '. Might as well stop here.' 1310 1310 abort_message='see above' 1311 1311 CALL abort_physic(modname,abort_message,1) … … 2290 2290 ELSE 2291 2291 ! DC: make sure the final "1" index was meant for 1st H2O phase (vapor) !!! 2292 ! tr_seri(:,:,strIdx(tracers(:)%name,addPhase('H2O','g'))) = 0.0 2293 tr_seri(:,:,strIdx(tracers(:)%name,addPhase('H2O','v',''))) = 0.0 2292 tr_seri(:,:,strIdx(tracers(:)%name,addPhase('H2O','g'))) = 0.0 2294 2293 ENDIF 2295 2294 ! -
LMDZ6/trunk/libf/phylmdiso/phys_output_mod.F90
r4089 r4120 35 35 USE iophy 36 36 USE dimphy 37 USE infotrac_phy, ONLY: nqtot, tracers, type_trac, niso, ntraciso, maxlen 37 USE infotrac_phy, ONLY: nqtot, tracers, type_trac, niso, ntraciso 38 USE strings_mod, ONLY: maxlen 38 39 USE ioipsl 39 40 USE phys_cal_mod, only : hour, calend -
LMDZ6/trunk/libf/phylmdiso/physiq_mod.F90
r4119 r4120 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, nqCO2, ok_isotopes 42 USE readTracFiles_mod, ONLY: phases_sep 43 USE strings_mod, ONLY: strIdx 41 USE infotrac, ONLY: iso_num, iso_indnum 42 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac, nqCO2, ok_isotopes, indnum_fn_num 43 USE readTracFiles_mod, ONLY: addPhase 44 USE strings_mod, ONLY: strIdx, strStack, int2str 44 45 USE iophy 45 46 USE limit_read_mod, ONLY : init_limit_read … … 126 127 #ifdef ISO 127 128 USE infotrac_phy, ONLY: & 128 iqiso, iso_indnum,ok_isotrac,niso, ntraciso129 iqiso,ok_isotrac,niso, ntraciso 129 130 USE isotopes_mod, ONLY: iso_eau,iso_HDO,iso_O18,iso_O17,iso_HTO, & 130 131 & bidouille_anti_divergence,ok_bidouille_wake, & … … 1392 1393 IF ((iflag_ice_thermo.gt.0).and.(nqo==2)) THEN 1393 1394 WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', & 1394 '(H2O v, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.'1395 '(H2O_g, H2O_l, H2O_s) but nqo=', nqo, '. Might as well stop here.' 1395 1396 abort_message='see above' 1396 1397 CALL abort_physic(modname,abort_message,1) … … 1405 1406 IF (ok_ice_sursat.AND.(nqo.NE.4)) THEN 1406 1407 WRITE (lunout, *) ' ok_ice_sursat=y requires 4 H2O tracers ', & 1407 '(H2O v, H2Ol, H2Oi, rnebi) but nqo=', nqo, '. Might as well stop here.'1408 '(H2O_g, H2O_l, H2O_s, H2O_r) but nqo=', nqo, '. Might as well stop here.' 1408 1409 abort_message='see above' 1409 1410 CALL abort_physic(modname,abort_message,1) … … 2433 2434 endif !if (nqo.eq.3) then 2434 2435 #endif 2435 if (ixt.gt.niso) then 2436 write(*,*) 'izone,iiso=',tracers(iqiso(ixt,ivap))%iso_iZone,iso_indnum(iqiso(ixt,ivap)) 2437 endif 2436 if (ixt.gt.niso) write(*,*) 'izone=',tracers(iqiso(ixt,ivap))%iso_iZone 2438 2437 DO k = 1, klev 2439 2438 DO i = 1, klon … … 2494 2493 ELSE 2495 2494 ! DC: make sure the final "1" index was meant for 1st H2O phase (vapor) !!! 2496 ! tr_seri(:,:,strIdx(tracers(:)%name,'H2O'//phases_sep//'g')) = 0.0 2497 tr_seri(:,:,strIdx(tracers(:)%name,'H2Ov')) = 0.0 2495 tr_seri(:,:,strIdx(tracers(:)%name,addPhase('H2O','g'))) = 0.0 2498 2496 ENDIF 2499 2497 !
Note: See TracChangeset
for help on using the changeset viewer.