Index: trunk/LMDZ.TITAN.old/Tools/README =================================================================== --- trunk/LMDZ.TITAN.old/Tools/README (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/README (revision 1643) @@ -0,0 +1,15 @@ +Please refer to the documentation on the SVN trunk, +DOC/documentation/vt-tools.pdf + +List of tools: +(zrecast is now common to everybody, in UTIL/) +angmom +energy +fft +psi +stability +tem +tmc + +Known bugs: + Index: trunk/LMDZ.TITAN.old/Tools/angmom.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/angmom.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/angmom.F90 (revision 1643) @@ -0,0 +1,865 @@ +program angmom + +! SL 12/2009: +! This program reads 4D (lon-lat-alt-time) fields directly from LMD (or CAM) outputs +! without regrid : histmth OR from files recast in log P coordinates (_P) +! (+ dynzon for LMD if present, but beware of recast consistency) +! +! it computes: +! dmass -- 4D -- mass of each cell +! osam -- 4D -- specific angular momentum (omega term) +! rsam -- 4D -- specific angular momentum (zonal wind term) +! oaam -- 1D -- integrated angular momentum (omega term) +! raam -- 1D -- integrated angular momentum (zonal wind term) +! tmou -- 1D -- Mountain torque +! tbls -- 1D -- Surface friction torque IF duvdf is present +! or if simple friction +! tdyn -- 1D -- Dynamics torque IF dudyn is present +! tajs -- 1D -- Torque from convective adjustment IF dudyn is present +! tgwo -- 1D -- Orographic GW torque IF dugwo is present +! tgwno -- 1D -- Non-Orographic GW torque IF dugwno is present +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - surface pressure and surface geopotential +! - zonal wind +! Optional: dudyn, duvdf, duajs, dugwo, dugwno (acceleration terms from physiq param) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name +character (len=128) :: dzfile ! input dynzon file name +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer dzfid ! NetCDF input dynzon file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer latdz_dimid,altdz_dimid,timedz_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid, tmpvarid +integer latdz_varid,altdz_varid,timedz_varid +integer :: datashape1d ! shape of 1D datasets +integer,dimension(2) :: datashape2d ! shape of 2D datasets +integer,dimension(3) :: datashape3d ! shape of 3D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along presnivs (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:),allocatable :: phis3d ! surface geopotential +real,dimension(:,:),allocatable :: phis ! surface geopotential +real,dimension(:,:,:,:),allocatable :: temp ! atmospheric temperature +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) + +real,dimension(:,:,:,:),allocatable :: duvdf ! Friction in BL +real,dimension(:,:,:,:),allocatable :: dudyn ! Dynamics +real,dimension(:,:,:,:),allocatable :: duajs ! Convective adjustment +real,dimension(:,:,:,:),allocatable :: dugwo ! Orographic Gravity Waves +real,dimension(:,:,:,:),allocatable :: dugwno ! Non-Orographic Gravity Waves + +real,dimension(:,:,:),allocatable :: dmcdyn ! Dynamics dAM from dynzon +real,dimension(:,:,:),allocatable :: dmcdis ! Dissip dAM from dynzon +real,dimension(:,:,:),allocatable :: dmcspg ! Sponge dAM from dynzon +real,dimension(:,:,:),allocatable :: dmcphy ! Physics dAM from dynzon + +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) +real,dimension(:,:,:,:),allocatable :: osam ! planetary rotation specific ang (m2/s) +real,dimension(:,:,:,:),allocatable :: rsam ! zonal wind specific ang (m2/s) +real,dimension(:),allocatable :: oaam ! planetary rotation total ang (kg m2/s) +real,dimension(:),allocatable :: raam ! zonal wind total ang (kg m2/s) +real,dimension(:),allocatable :: tmou ! mountain torque (kg m2/s2) +real,dimension(:),allocatable :: tdyn ! dynamics torque (kg m2/s2) +real,dimension(:),allocatable :: tajs ! convective adjustment torque (kg m2/s2) +real,dimension(:),allocatable :: tbls ! friction torque (kg m2/s2) +real,dimension(:),allocatable :: tgwo ! oro GW torque (kg m2/s2) +real,dimension(:),allocatable :: tgwno! non-oro GW torque (kg m2/s2) +real,dimension(:),allocatable :: tdyndz ! dynamics torque (kg m2/s2) from dynzon +real,dimension(:),allocatable :: tdisdz ! dissip torque (kg m2/s2) from dynzon +real,dimension(:),allocatable :: tspgdz ! sponge torque (kg m2/s2) from dynzon +real,dimension(:),allocatable :: tphydz ! physics torque (kg m2/s2) from dynzon + +! for angular momentum budget normalisation +real,parameter :: hadley=1.e18 +real,parameter :: hadday=1.e25 + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +integer idlsurf ! for option ideal surface +logical :: flag_duvdf,flag_dudyn,flag_duajs,flag_dugwo,flag_dugwno,lmdflag,dzflag + +real :: deltalat,deltalon ! lat and lon intervals in radians +real :: tmpp ! temporary pressure +real :: dz ! altitude diff +real :: signe ! orientation of lon axis for mountain torque computation +real :: norm ! for dynzon + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) " Program valid for Venus or Titan LMD, or Venus CAM output files" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" +if(lon(1).gt.lon(2)) then + signe=-1. +else + signe=1. +endif + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading pressure levels" +if(.not.lmdflag) then +! in CAM files, pressure in mbar and reversed... + call reverselev(altlength,plev) + plev=plev*100. ! convertion to Pa +endif + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +! Time axis IN PLANET DAYS + +if(.not.lmdflag) then +! in CAM files, time in Earth days... +! => seconds + time=time*86400. +endif +time=time/localday + +!=============================================================================== +! 1.3 dynzon file if present +!=============================================================================== + +! RAJOUTER UN TEST COHERENCE _P... + +dzflag=.false. + +if(lmdflag) then + +write(*,*) "Enter dynzon file name ( if not present):" + +read(*,'(a128)') dzfile +write(*,*) "" + +if(dzfile.ne."") then + +! open dynzon file +ierr = NF_OPEN(dzfile,NF_NOWRITE,dzfid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(dzfile) +else + dzflag=.true. +endif + +endif ! dzfile.ne."" +endif ! lmdflag + +!=============================================================================== +! 1.4 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_GAM.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure and geopotential +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) +allocate(phis3d(lonlength,latlength,timelength)) +allocate(phis(lonlength,latlength)) + +text="PS" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for ps instead... " + text="ps" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" + endif +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" +if((.not.lmdflag).and.(planet.eq."Venus")) call reverse3d(lonlength,latlength,timelength,ps) + +text="PHIS" +call get_var3d(infid,lonlength,latlength,timelength,text,phis3d,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " Failed to get PHIS ID (3d), looking for phis (2d) instead... " + text="phis" + call get_var2d(infid,lonlength,latlength,text,phis,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get phis ID" + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface geopotential" +else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface geopotential" + phis(:,:)=phis3d(:,:,1) + if((.not.lmdflag).and.(planet.eq."Venus")) call reverse2d(lonlength,latlength,phis) +endif + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitu(lonlength,latlength,altlength,timelength)) + +! zonal wind vitu / U (in m/s) +if(lmdflag) then + text="vitu" +else + text="U" +endif + +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get U ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zonal wind" + +if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,vitu) + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== +! Only needed if g(z) on Titan... + +!allocate(za(lonlength,latlength,altlength,timelength)) + +!text="zareoid" +!call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +!if (ierr1.ne.NF_NOERR) stop "Error: Failed to get za ID" +!if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid" + +!=============================================================================== +! 2.1.5 Friction in Boundary layer +!=============================================================================== +allocate(duvdf(lonlength,latlength,altlength,timelength)) + +if(lmdflag) then + text="duvdf" +else + text="DUVDF" +endif +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,duvdf,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Failed to get duvdf ID" + flag_duvdf = .false. + +if(.not.lmdflag) then +! IDEAL FRICTION ? +write(*,*) "" +write(*,*) " Is the friction at surface ideal ? 0 for no, 1 for yes" +write(*,*) " duvdf = -u/(86400*30) in surface layer" +write(*,*) " timescale hard-coded: 30 Edays" +read(*,'(i1)') idlsurf +!write(*,*) "" +!write(*,*) " ASSUMED YES ! " +!idlsurf=1 +write(*,*) "" +else +idlsurf=0 +endif + +if (idlsurf.eq.1) then + flag_duvdf = .true. + duvdf = 0. + ilev=1 +do ilon=1,lonlength + do ilat=1,latlength + do itim=1,timelength + duvdf(ilon,ilat,ilev,itim) = vitu(ilon,ilat,ilev,itim) * (-1.)/(86400.*30.) + enddo + enddo +enddo +endif + +else !err1 + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading duvdf" + if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,duvdf) + flag_duvdf = .true. +endif !err1 + +!=============================================================================== +! 2.1.6 Orographic and Non-orographic gravity waves +!=============================================================================== +allocate(dugwo(lonlength,latlength,altlength,timelength)) +allocate(dugwno(lonlength,latlength,altlength,timelength)) + +if(lmdflag) then + +text="dugwo" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,dugwo,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Failed to get dugwo ID" + flag_dugwo = .false. +else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dugwo" + flag_dugwo = .true. +endif + +text="dugwno" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,dugwno,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Failed to get dugwno ID" + flag_dugwno = .false. +else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dugwno" + flag_dugwno = .true. +endif + +else ! lmdflag + print*,"dugwo and dugwno not in CAM simulations" + flag_dugwo = .false. + flag_dugwno = .false. +endif ! lmdflag + +!=============================================================================== +! 2.1.65 Accelerations from convective adjustment +!=============================================================================== +allocate(duajs(lonlength,latlength,altlength,timelength)) + +if(lmdflag) then + +text="duajs" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,duajs,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Failed to get duajs ID" + flag_duajs = .false. +else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading duajs" + flag_duajs = .true. +endif + +else ! lmdflag + print*,"duajs not in CAM simulations" + flag_duajs = .false. +endif ! lmdflag + +!=============================================================================== +! 2.1.7 Dynamics (includes the mountain torque...) +!=============================================================================== +allocate(dudyn(lonlength,latlength,altlength,timelength)) + +if(lmdflag) then + text="dudyn" +else + text="DUDYN" +endif +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,dudyn,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Failed to get dudyn ID" + flag_dudyn = .false. +else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dudyn" + if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,dudyn) + flag_dudyn = .true. +endif + +!=============================================================================== +! 2.1.8 Dynzon dAM/dt +!=============================================================================== +if(dzflag) then + +allocate(dmcdyn(latlength-1,altlength,timelength)) +allocate(dmcdis(latlength-1,altlength,timelength)) +allocate(dmcspg(latlength-1,altlength,timelength)) +allocate(dmcphy(latlength-1,altlength,timelength)) + + text="dmcdyn" +call get_var3d(dzfid,latlength-1,altlength,timelength,text,dmcdyn,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get dmcdyn ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dmcdyn" + + text="dmcdis" +call get_var3d(dzfid,latlength-1,altlength,timelength,text,dmcdis,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get dmcdis ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dmcdis" + + text="dmcspg" +call get_var3d(dzfid,latlength-1,altlength,timelength,text,dmcspg,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get dmcspg ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dmcspg" + + text="dmcphy" +call get_var3d(dzfid,latlength-1,altlength,timelength,text,dmcphy,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get dmcphy ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading dmcphy" + +endif ! dzflag + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== +allocate(rayon(lonlength,latlength,altlength,timelength)) +allocate(grav(lonlength,latlength,altlength,timelength)) +allocate(dmass(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations + if (vitu(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) + else + rayon(ilon,ilat,ilev,itim) = miss_val + grav(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo +enddo ! timelength + +call cellmass(infid,latlength,lonlength,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +!=============================================================================== +! 2.2.3 Specific angular momentum +!=============================================================================== +allocate(osam(lonlength,latlength,altlength,timelength)) +allocate(rsam(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + osam(ilon,ilat,ilev,itim) = & + rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim) & + * coslat(ilat)*coslat(ilat) & + * omega + rsam(ilon,ilat,ilev,itim) = vitu(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) + else + osam(ilon,ilat,ilev,itim) = miss_val + rsam(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo + +enddo ! timelength + +!=============================================================================== +! 2.2.4 Total angular momentum +!=============================================================================== +allocate(oaam(timelength)) +allocate(raam(timelength)) + +do itim=1,timelength + +oaam(itim) = 0. +raam(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + oaam(itim) = oaam(itim) & + + osam(ilon,ilat,ilev,itim)/ hadday * dmass(ilon,ilat,ilev,itim) + raam(itim) = raam(itim) & + + rsam(ilon,ilat,ilev,itim)/ hadday * dmass(ilon,ilat,ilev,itim) + endif + enddo + enddo +enddo +if (oaam(itim).eq.0.) then + oaam(itim) = miss_val + raam(itim) = miss_val +endif + +enddo ! timelength + +!=============================================================================== +! 2.2.5 Mountain, friction, convective adjustment, dynamics and GW torques +!=============================================================================== +allocate(tmou(timelength)) +if (flag_dudyn) allocate(tdyn(timelength)) +if (flag_duajs) allocate(tajs(timelength)) +if (flag_duvdf) allocate(tbls(timelength)) +if (flag_dugwo) allocate(tgwo(timelength)) +if (flag_dugwno) allocate(tgwno(timelength)) + +do itim=1,timelength + +tmou(itim) = 0. +do ilon=1,lonlength + do ilat=2,latlength-1 + if (ilon.eq.lonlength) then + dz = (phis( 1,ilat) -phis(ilon,ilat))/g0 + tmpp = (ps( 1,ilat,itim) +ps(ilon,ilat,itim))/2. + else + dz = (phis(ilon+1,ilat) -phis(ilon,ilat))/g0 + tmpp = (ps(ilon+1,ilat,itim) +ps(ilon,ilat,itim))/2. + endif + tmou(itim) = tmou(itim) + a0*a0* deltalat*coslat(ilat) & + * signe*dz*tmpp & + / hadley + enddo +enddo + +if (flag_dudyn) then +tdyn(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + tdyn(itim) = tdyn(itim) + dudyn(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) & + * dmass(ilon,ilat,ilev,itim) & + / hadley + endif + enddo + enddo +enddo + if (tdyn(itim).eq.0.) tdyn(itim) = miss_val +endif + +if (flag_duajs) then +tajs(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + tajs(itim) = tajs(itim) + duajs(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) & + * dmass(ilon,ilat,ilev,itim) & + / hadley + endif + enddo + enddo +enddo + if (tajs(itim).eq.0.) tajs(itim) = miss_val +endif + +if (flag_duvdf) then +tbls(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + tbls(itim) = tbls(itim) + duvdf(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) & + * dmass(ilon,ilat,ilev,itim) & + / hadley + endif + enddo + enddo +enddo + if (tbls(itim).eq.0.) tbls(itim) = miss_val +endif + +if (flag_dugwo) then +tgwo(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + tgwo(itim) = tgwo(itim) + dugwo(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) & + * dmass(ilon,ilat,ilev,itim) & + / hadley + endif + enddo + enddo +enddo + if (tgwo(itim).eq.0.) tgwo(itim) = miss_val +endif + +if (flag_dugwno) then +tgwno(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + tgwno(itim) = tgwno(itim) + dugwno(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) & + * dmass(ilon,ilat,ilev,itim) & + / hadley + endif + enddo + enddo +enddo + if (tgwno(itim).eq.0.) tgwno(itim) = miss_val +endif + +enddo ! timelength + +!=============================================================================== +! 2.2.6 Torques from dynzon +!=============================================================================== +if(dzflag) then + +allocate(tdyndz(timelength)) +allocate(tdisdz(timelength)) +allocate(tspgdz(timelength)) +allocate(tphydz(timelength)) +norm=2./3.*a0*a0*omega + +do itim=1,timelength + +tdyndz(itim) = 0. +tdisdz(itim) = 0. +tspgdz(itim) = 0. +tphydz(itim) = 0. +do ilon=1,lonlength + do ilat=2,latlength + do ilev=1,altlength + tdyndz(itim) = tdyndz(itim) + & + (dmcdyn(ilat-1,ilev,itim)+dmcdyn(ilat,ilev,itim))/(2*lonlength) & + * norm * dmass(ilon,ilat,ilev,itim) / hadley + tdisdz(itim) = tdisdz(itim) + & + (dmcdis(ilat-1,ilev,itim)+dmcdis(ilat,ilev,itim))/(2*lonlength) & + * norm * dmass(ilon,ilat,ilev,itim) / hadley + tspgdz(itim) = tspgdz(itim) + & + (dmcspg(ilat-1,ilev,itim)+dmcspg(ilat,ilev,itim))/(2*lonlength) & + * norm * dmass(ilon,ilat,ilev,itim) / hadley + tphydz(itim) = tphydz(itim) + & + (dmcphy(ilat-1,ilev,itim)+dmcphy(ilat,ilev,itim))/(2*lonlength) & + * norm * dmass(ilon,ilat,ilev,itim) / hadley + enddo + enddo +enddo + if (tdyndz(itim).eq.0.) tdyndz(itim) = miss_val + if (tdisdz(itim).eq.0.) tdisdz(itim) = miss_val + if (tspgdz(itim).eq.0.) tspgdz(itim) = miss_val + if (tphydz(itim).eq.0.) tphydz(itim) = miss_val + +enddo ! timelength + +endif ! dzflag + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +! Check variables to output + +do itim=1,timelength + if (flag_dudyn .and.( tdyn(itim).eq.miss_val)) flag_dudyn =.false. + if (flag_duajs .and.( tajs(itim).eq.miss_val)) flag_duajs =.false. + if (flag_duvdf .and.( tbls(itim).eq.miss_val)) flag_duvdf =.false. + if (flag_dugwo .and.( tgwo(itim).eq.miss_val)) flag_dugwo =.false. + if (flag_dugwno.and.(tgwno(itim).eq.miss_val)) flag_dugwno=.false. +enddo ! timelength + +if(dzflag) then +do itim=1,timelength + if (tdyndz(itim).eq.miss_val) dzflag=.false. + if (tdisdz(itim).eq.miss_val) dzflag=.false. + if (tspgdz(itim).eq.miss_val) dzflag=.false. + if (tphydz(itim).eq.miss_val) dzflag=.false. +enddo ! timelength +endif ! dzflag + + +! 1D Variables + +datashape1d=time_dimid + +call write_var1d(outfid,datashape1d,timelength,& + "oaam ", "Total rotation ang ","E25kgm2s-1",miss_val,& + oaam ) + +call write_var1d(outfid,datashape1d,timelength,& + "raam ", "Total wind ang ","E25kgm2s-1",miss_val,& + raam ) + +call write_var1d(outfid,datashape1d,timelength,& + "tmou ", "Mountain torque ","E18kgm2s-2",miss_val,& + tmou ) + +if (flag_dudyn) then +call write_var1d(outfid,datashape1d,timelength,& + "tdyn ", "Dynamics torque ","E18kgm2s-2",miss_val,& + tdyn ) +endif + +if (flag_duajs) then +call write_var1d(outfid,datashape1d,timelength,& + "tajs ", "Dynamics torque ","E18kgm2s-2",miss_val,& + tajs ) +endif + +if (flag_duvdf) then +call write_var1d(outfid,datashape1d,timelength,& + "tbls ", "Friction torque ","E18kgm2s-2",miss_val,& + tbls ) +endif + +if (flag_dugwo) then +call write_var1d(outfid,datashape1d,timelength,& + "tgwo ", "Orographic GW torque","E18kgm2s-2",miss_val,& + tgwo ) +endif + +if (flag_dugwno) then +call write_var1d(outfid,datashape1d,timelength,& + "tgwno ", "Non-orogr. GW torque","E18kgm2s-2",miss_val,& + tgwno ) +endif + +if(dzflag) then + +call write_var1d(outfid,datashape1d,timelength,& + "tdyndz ", "Dynamics torque DZ ","E18kgm2s-2",miss_val,& + tdyndz ) + +call write_var1d(outfid,datashape1d,timelength,& + "tdisdz ", "Dissip torque DZ ","E18kgm2s-2",miss_val,& + tdisdz ) + +call write_var1d(outfid,datashape1d,timelength,& + "tspgdz ", "Sponge torque DZ ","E18kgm2s-2",miss_val,& + tspgdz ) + +call write_var1d(outfid,datashape1d,timelength, & + "tphydz ", "Physics torque DZ ","E18kgm2s-2",miss_val,& + tphydz ) + +endif ! dzflag + +! 2D variables + +datashape2d(1)=lon_dimid +datashape2d(2)=lat_dimid + +call write_var2d(outfid,datashape2d,lonlength,latlength,& + "phis ", "Surface geopot ","m2 s-2 ",miss_val,& + phis ) + +! 3D variables + +datashape3d(1)=lon_dimid +datashape3d(2)=lat_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,lonlength,latlength,timelength,& + "ps ", "Surface pressure ","Pa ",miss_val,& + ps ) + +! 4D variables + +datashape4d(1)=lon_dimid +datashape4d(2)=lat_dimid +datashape4d(3)=alt_dimid +datashape4d(4)=time_dimid + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "dmass ", "Mass ","kg ",miss_val,& + dmass ) + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "osam ", "Specific rotat ang ","E25m2s-1 ",miss_val,& + osam ) + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "rsam ", "Specific wind ang ","E25m2s-1 ",miss_val,& + rsam ) + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'Error, failed to close output file ',outfile +endif + + +end program Index: trunk/LMDZ.TITAN.old/Tools/compile_pgf =================================================================== --- trunk/LMDZ.TITAN.old/Tools/compile_pgf (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/compile_pgf (revision 1643) @@ -0,0 +1,9 @@ +# path for netcdf should be adapted to your configuration ! + +#\cp -f $2.h planet.h + pgf95 -Bstatic cpdet.F90 moyzon.F moyzon2.F moytim.F dx_dp.F epflux.F90 \ + io.F90 dmass.F90 reverse.F90 $1.F90 \ +-I/usr/include/netcdf-3 \ +-L/usr/lib64 -lnetcdff -lnetcdf -o $1-$2.e + +\rm *.o Index: trunk/LMDZ.TITAN.old/Tools/compilefft_pgf =================================================================== --- trunk/LMDZ.TITAN.old/Tools/compilefft_pgf (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/compilefft_pgf (revision 1643) @@ -0,0 +1,13 @@ +# path for netcdf should be adapted to your configuration ! +# path for fftw3 should be adapted to your configuration ! + +#\rm planet.h +#ln -s $2.h planet.h + pgf95 -Bstatic cpdet.F90 moyzon.F moyzon2.F moytim.F dx_dp.F epflux.F90 \ + io.F90 dmass.F90 reverse.F90 $1.F90 \ +-I/usr/include/netcdf-3 \ +-L/usr/lib64 -lnetcdff -lnetcdf \ +-I/opt/fftw-3.3.2/include \ +-L/opt/fftw-3.3.2/lib -lfftw3 -o $1-$2.e + +\rm *.o Index: trunk/LMDZ.TITAN.old/Tools/cpdet.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/cpdet.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/cpdet.F90 (revision 1643) @@ -0,0 +1,99 @@ +! ADAPTATION GCM POUR CP(T) +!====================================================================== +! S. Lebonnois, 10/2007: +! +! VENUS: Cp(T) = cpp*(T/T0)^nu +! avec T0=460. et nu=0.35 +!c cpp=RCPD=cp0 = 1000. +! R/RCPD = RKAPPA +! +! La fonction d'Exner reste pk = RCPD*(play/pref)**RKAPPA +! +! T et teta (temperature potentielle) sont liees par: +! +! integrale[teta a T](cp/T dT) = integrale[pref a p](R/p dp) +! +! Dans le cas de l'expression pour Venus, ca donne: +! +! teta**nu = T**nu - nu * T0**nu * ln[ (p/pref)**RKAPPA ] +! ou +! teta**nu = T**nu - nu * T0**nu * ln[pk/RCPD] +! +! On passe de T a teta par t2tpot(t,teta,pk) +! On passe de teta a T par tpot2t(teta,t,pk) +! +! Pour DT <-> Dteta, on utilise: dteta = dT *(T/teta)**(nu-1) +! -> routine dt2dtpot(dt,dteta,t,teta) +! (utilisee seulement pour le contregradient) +! +!====================================================================== + + FUNCTION cpdet(t) + IMPLICIT none +#include "planet.h" + + real cpdet,t + + if(nu.ne.0.) then + cpdet = cp0*(t/t0)**nu + else + cpdet = cp0 + endif + + return + end + +!====================================================================== +!====================================================================== + + SUBROUTINE t2tpot(npoints,yt, yteta, ypk) + IMPLICIT none +!====================================================================== +! Arguments: +! +! yt --------input-R- Temperature +! yteta-------output-R- Temperature potentielle +! ypk --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA +! +!====================================================================== +#include "planet.h" + + integer npoints + REAL yt(npoints), yteta(npoints), ypk(npoints) + + if(nu.ne.0.) then + yteta = yt**nu - nu * t0**nu * log(ypk/cp0) + yteta = yteta**(1./nu) + else + yteta = yt * cp0/ypk + endif + + end + +!====================================================================== +!====================================================================== + + SUBROUTINE tpot2t(npoints,yteta, yt, ypk) + IMPLICIT none +!====================================================================== +! Arguments: +! +! yteta--------input-R- Temperature potentielle +! yt -------output-R- Temperature +! ypk --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA +! +!====================================================================== +#include "planet.h" + + integer npoints + REAL yt(npoints), yteta(npoints), ypk(npoints) + + if(nu.ne.0.) then + yt = yteta**nu + nu * t0**nu * log(ypk/cp0) + yt = yt**(1./nu) + else + yt = yteta * ypk/cp0 + endif + + end + Index: trunk/LMDZ.TITAN.old/Tools/dmass.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/dmass.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/dmass.F90 (revision 1643) @@ -0,0 +1,176 @@ +subroutine cellmass(infid,latlength,lonlength,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,latrad,plev,ps,grav,rayon, & + dmass ) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer infid ! NetCDF input file ID +integer lonlength ! # of grid points along longitude +integer latlength ! # of grid points along latitude +integer altlength ! # of grid point along altitude (of input datasets) +integer timelength ! # of points along time +logical lmdflag ! true=LMD, false=CAM +real :: miss_val ! missing value +real :: deltalat,deltalon ! lat and lon intervals in radians +real,dimension(latlength) :: latrad ! latitudes in radians +real,dimension(altlength) :: plev ! Pressure levels (Pa) +real,dimension(lonlength,latlength,timelength),intent(in) :: ps ! surface pressure +real,dimension(lonlength,latlength,altlength,timelength),intent(in) :: grav,rayon +real,dimension(lonlength,latlength,altlength,timelength),intent(out) :: dmass + +!local +character (len=64) :: text ! to store some text +real,dimension(:),allocatable :: aps,bps ! hybrid vertical coordinates +real,dimension(:,:,:,:),allocatable :: press ! GCM atmospheric pressure +real,dimension(:),allocatable :: pp ! Pressure levels (Pa) +real,dimension(:,:,:,:),allocatable :: deltap ! pressure thickness of each layer (Pa) +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +real :: tmpp ! temporary pressure +real :: p0 ! GCM reference pressure +integer tmpvarid + +include "planet.h" + +!=============================================================================== +! 2.2.1 Pressure intervals +!=============================================================================== +allocate(deltap(lonlength,latlength,altlength,timelength)) +allocate(press(lonlength,latlength,altlength,timelength)) +allocate(pp(altlength)) + +if(lmdflag) then ! LMD vs CAM + text="pres" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,press,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) then +! assume we are using _P files +do itim=1,timelength + do ilon=1,lonlength + do ilat=1,latlength + press(ilon,ilat,:,itim) = plev + enddo + enddo +enddo + else + if (ierr2.ne.NF_NOERR) stop "Error: Failed reading pres" + endif + +else ! LMD vs CAM + ierr=NF_INQ_VARID(infid,"P0",tmpvarid) + if (ierr.ne.NF_NOERR) then + write(*,*) "Failed to get P0 ID, used psref=",psref + p0=psref + else + ierr=NF_GET_VAR_REAL(infid,tmpvarid,p0) + if (ierr.ne.NF_NOERR) then + write(*,*) "Failed reading reference pressure, used psref=",psref + p0=psref + endif + endif + ! hybrid coordinate aps/hyam + text="hyam" + ierr=NF_INQ_VARID(infid,text,tmpvarid) + if (ierr.ne.NF_NOERR) then + stop "Error: Could not find aps/hyam coordinates" + else + allocate(aps(altlength)) + ierr=NF_GET_VAR_REAL(infid,tmpvarid,aps) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed reading aps/hyam" + endif + call reverselev(altlength,aps) + endif + + ! hybrid coordinate hybm + text="hybm" + ierr=NF_INQ_VARID(infid,text,tmpvarid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get bps/hybm ID" + else + allocate(bps(altlength)) + ierr=NF_GET_VAR_REAL(infid,tmpvarid,bps) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed reading bps/hybm" + endif + call reverselev(altlength,bps) + endif + + aps=aps*p0 + + do itim=1,timelength + do ilev=1,altlength + do ilat=1,latlength + do ilon=1,lonlength + press(ilon,ilat,ilev,itim)=aps(ilev)+bps(ilev)*ps(ilon,ilat,itim) + enddo + enddo + enddo + enddo + +endif ! LMD vs CAM + +do itim=1,timelength + +do ilon=1,lonlength + do ilat=1,latlength + tmpp=ps(ilon,ilat,itim) + pp=press(ilon,ilat,:,itim) +if (tmpp.ge.pp(1)) then + deltap(ilon,ilat,1,itim)= tmpp - exp((log(pp(1))+log(pp(2)))/2.) ! initialization, rectified with ps below +else + deltap(ilon,ilat,1,itim)= miss_val +endif +do ilev=2,altlength-1 + deltap(ilon,ilat,ilev,itim)= exp((log(pp(ilev-1))+log(pp(ilev)))/2.)-& + exp((log(pp(ilev))+log(pp(ilev+1)))/2.) +enddo +deltap(ilon,ilat,altlength,itim)=exp((log(pp(altlength-1))+log(pp(altlength)))/2.) + enddo +enddo + +do ilon=1,lonlength + do ilat=1,latlength + tmpp=ps(ilon,ilat,itim) + pp=press(ilon,ilat,:,itim) + do ilev=altlength,2,-1 + if ((pp(ilev).le.tmpp).and.(pp(ilev-1).gt.tmpp)) then + deltap(ilon,ilat,ilev,itim)= tmpp - & + exp((log(pp(ilev))+log(pp(ilev+1)))/2.) + elseif (pp(ilev).gt.tmpp) then + deltap(ilon,ilat,ilev,itim)=miss_val + endif + enddo + enddo +enddo + +enddo ! timelength + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== + +do itim=1,timelength + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if ((deltap(ilon,ilat,ilev,itim).ne.miss_val) & + .and. (rayon(ilon,ilat,ilev,itim).ne.miss_val) & + .and. (grav(ilon,ilat,ilev,itim).ne.miss_val)) then + dmass(ilon,ilat,ilev,itim) = & + rayon(ilon,ilat,ilev,itim)*cos(latrad(ilat))*deltalon & + * rayon(ilon,ilat,ilev,itim)*deltalat & + * deltap(ilon,ilat,ilev,itim)/grav(ilon,ilat,ilev,itim) + else + dmass(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo + +enddo ! timelength + +end subroutine cellmass Index: trunk/LMDZ.TITAN.old/Tools/dx_dp.F =================================================================== --- trunk/LMDZ.TITAN.old/Tools/dx_dp.F (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/dx_dp.F (revision 1643) @@ -0,0 +1,74 @@ + SUBROUTINE dx_dp(jjp1,llm,indefini,pniv,x,dxdp) +c======================================================================= +c +c +c Subject: +c ------ +c Calcul de la derivee /p d'1 moyenne zonale +c EXTRAPOLEE EN COORDONNEE DE PRESSION +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +c Arguments: +c ---------- + + integer jjp1,llm + real indefini + REAL pniv(llm) + REAL x(jjp1,llm) + REAL dxdp(jjp1,llm) + +c Local: +c ------ + + INTEGER i,j,l , k + +c----------------------------------------------------------------------- + do j=1,jjp1 + if ((x(j,1).ne.indefini).and.(x(j,2).ne.indefini)) then + dxdp(j,1) = (x(j,2)-x(j,1))/(pniv(2) - pniv(1)) + else + dxdp(j,1) = indefini + end if + + do l=2,llm-1 + if ((x(j,l-1).ne.indefini).and.(x(j,l+1).ne.indefini))then + dxdp(j,l)= (x(j,l+1)-x(j,l-1))/(pniv(l+1) - pniv(l-1)) + else if((x(j,l+1).ne.indefini).and.(x(j,l).ne.indefini))then + dxdp(j,l)= (x(j,l+1)-x(j,l)) /(pniv(l+1) - pniv(l)) + else if((x(j,l-1).ne.indefini).and.(x(j,l).ne.indefini))then + dxdp(j,l)= (x(j,l)-x(j,l-1)) /(pniv(l) - pniv(l-1)) + else + dxdp(j,l)= indefini + end if + end do + if ((x(j,llm).ne.indefini).and.(x(j,llm-1).ne.indefini)) then + dxdp(j,llm)= (x(j,llm)-x(j,llm-1))/(pniv(llm)-pniv(llm-1)) + else + dxdp(j,llm)= indefini + end if + end do + +c Test + + do j=1,jjp1 + do l = 1, llm + if ( (abs(dxdp(j,l)).gt.(abs(indefini)/100.)).and. + . (dxdp(j,l).ne.indefini)) then + write(*,*) '----> j= ', j , ' l= ' , l + write(*,*) 'dxdp(j,l) ' , dxdp(j,l) + write(*,*) 'x' , (x(j,k),k=1,llm) + write(*,*) 'pniv' , pniv + write(*,*) + end if + end do + end do + + + + RETURN + END Index: trunk/LMDZ.TITAN.old/Tools/earth.h =================================================================== --- trunk/LMDZ.TITAN.old/Tools/earth.h (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/earth.h (revision 1643) @@ -0,0 +1,22 @@ +! Parameters needed to integrate hydrostatic equation: + +real,parameter :: g0=9.80616 +!g0: exact mean gravity at radius=6371.22km + +real,parameter :: a0=6371.22E3 +!a0: 'mean' radius=6371.22km + +real,parameter :: R0=287.1 ! molecular gas constant + +real,parameter :: psref=1.0e5 ! reference pressure at surface (Pa) + +real,parameter :: omega=7.29e-5 ! angular rotation speed (s-1) + +real,parameter :: localday=86400. ! local day (s) + +character (len=5),parameter :: planet="Earth" + +real,parameter :: cp0=1004.64 !doit etre egal a cpp (dyn) et RCPD (phy) +real,parameter :: t0=0. +real,parameter :: nu=0. + Index: trunk/LMDZ.TITAN.old/Tools/energy.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/energy.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/energy.F90 (revision 1643) @@ -0,0 +1,424 @@ +program energy + +! SL 12/2009: +! This program reads 4D (lon-lat-alt-time) fields directly from LMD outputs without regrid : histmth +! +! it computes: +! dmass -- 4D -- mass of each cell +! sek -- 4D -- specific kinetic energy +! ek -- 1D -- integrated kinetic energy +! sep -- 4D -- specific potential energy +! ep -- 1D -- integrated potential energy +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - surface pressure +! - atmospheric temperature +! - zonal and meridional winds + +! VERTICAL WIND SPEED IS NEGLECTED IN KINETIC ENERGY + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer :: datashape1d ! shape of 1D datasets +integer,dimension(2) :: datashape2d ! shape of 2D datasets +integer,dimension(3) :: datashape3d ! shape of 3D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along presnivs (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:,:),allocatable :: temp ! atmospheric temperature +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) + +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) +real,dimension(:,:,:,:),allocatable :: sek ! specific kinetic energy +real,dimension(:),allocatable :: ek ! total kinetic energy +real,dimension(:,:,:,:),allocatable :: sep ! specific potential energy +real,dimension(:),allocatable :: ep ! total potential energy + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops + +real :: deltalat,deltalon ! lat and lon intervals in radians +real,dimension(:,:,:,:),allocatable :: deltap ! pressure thickness of each layer (Pa) +real :: tmpp ! temporary pressure +real :: dz ! altitude diff +real :: signe ! orientation of lon axis for mountain torque computation +logical :: lmdflag + +real :: cpdet + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) " Program valid for Venus or Titan LMD, or Venus CAM output files" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" +if(lon(1).gt.lon(2)) then + signe=-1. +else + signe=1. +endif + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading presnivs (ie pressure levels)" +if(.not.lmdflag) then +! in CAM files, pressure in mbar and reversed... + call reverselev(altlength,plev) + plev=plev*100. ! convertion to Pa +endif + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +! Time axis IN PLANET DAYS + +if(.not.lmdflag) then +! in CAM files, time in Earth days... +! => seconds + time=time*86400. +endif +time=time/localday + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_NRG.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) + +text="ps" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" +if((.not.lmdflag).and.(planet.eq."Venus")) call reverse3d(lonlength,latlength,timelength,ps) + +!=============================================================================== +! 2.1.2 Atmospheric temperature +!=============================================================================== +allocate(temp(lonlength,latlength,altlength,timelength)) + +if(lmdflag) then + text="temp" +else + text="T" +endif +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for t instead... " + text="t" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get temperature ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading temperature" + +if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,temp) + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitu(lonlength,latlength,altlength,timelength)) +allocate(vitv(lonlength,latlength,altlength,timelength)) + +! zonal wind vitu (in m/s) +if(lmdflag) then + text="vitu" +else + text="U" +endif +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitu ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zonal wind" + +if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,vitu) + +! meridional wind vitv (in m/s) +if(lmdflag) then + text="vitv" +else + text="V" +endif +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitv ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading meridional wind" + +if(.not.lmdflag) call reverse4d(lonlength,latlength,altlength,timelength,vitv) + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== +! Only needed if g(z) on Titan... + +!allocate(za(lonlength,latlength,altlength,timelength)) + +!text="zareoid" +!call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +!if (ierr1.ne.NF_NOERR) stop "Error: Failed to get za ID" +!if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid" + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== +allocate(rayon(lonlength,latlength,altlength,timelength)) +allocate(grav(lonlength,latlength,altlength,timelength)) +allocate(dmass(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations +! if (za(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) +! else +! rayon(ilon,ilat,ilev,itim) = miss_val +! grav(ilon,ilat,ilev,itim) = miss_val +! endif + enddo + enddo +enddo +enddo ! timelength + +call cellmass(infid,latlength,lonlength,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +!=============================================================================== +! 2.2.6 Specific energies +!=============================================================================== +allocate(sek(lonlength,latlength,altlength,timelength)) +allocate(sep(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + if ((vitu(ilon,ilat,ilev,itim).lt.miss_val) & + .and.(vitv(ilon,ilat,ilev,itim).lt.miss_val)) then + sek(ilon,ilat,ilev,itim) = 0.5 * & + ( vitu(ilon,ilat,ilev,itim)*vitu(ilon,ilat,ilev,itim) & + + vitv(ilon,ilat,ilev,itim)*vitv(ilon,ilat,ilev,itim) ) + else + sek(ilon,ilat,ilev,itim) = miss_val + endif + if (temp(ilon,ilat,ilev,itim).ne.miss_val) then + sep(ilon,ilat,ilev,itim) = temp(ilon,ilat,ilev,itim) & + * cpdet(temp(ilon,ilat,ilev,itim)) + else + sep(ilon,ilat,ilev,itim) = miss_val + endif + else + sek(ilon,ilat,ilev,itim) = miss_val + sep(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo + +enddo ! timelength + +!=============================================================================== +! 2.2.7 Total energies +!=============================================================================== +allocate(ek(timelength)) +allocate(ep(timelength)) + +do itim=1,timelength + +ek(itim) = 0. +ep(itim) = 0. +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (sek(ilon,ilat,ilev,itim).ne.miss_val) then + ek(itim) = ek(itim) & + + sek(ilon,ilat,ilev,itim) * dmass(ilon,ilat,ilev,itim) + endif + if (sep(ilon,ilat,ilev,itim).ne.miss_val) then + ep(itim) = ep(itim) & + + sep(ilon,ilat,ilev,itim) * dmass(ilon,ilat,ilev,itim) + endif + enddo + enddo +enddo +if (ek(itim).eq.0.) then + ek(itim) = miss_val + ep(itim) = miss_val +endif + +enddo ! timelength + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +! 1D Variables + +datashape1d=time_dimid + +call write_var1d(outfid,datashape1d,timelength,& + "ek ", "Total kinetic energy","J ",miss_val,& + ek ) + +call write_var1d(outfid,datashape1d,timelength,& + "ep ", "Total pot energy ","J ",miss_val,& + ep ) + +! 3D variables + +datashape3d(1)=lon_dimid +datashape3d(2)=lat_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,lonlength,latlength,timelength,& + "ps ", "Surface pressure ","Pa ",miss_val,& + ps ) + +! 4D variables + +datashape4d(1)=lon_dimid +datashape4d(2)=lat_dimid +datashape4d(3)=alt_dimid +datashape4d(4)=time_dimid + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "dmass ", "Mass ","kg ",miss_val,& + dmass ) + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "sek ", "Specific kin energy ","J/kg ",miss_val,& + sek ) + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "sep ", "Specific pot energy ","J/kg ",miss_val,& + sep ) + + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'Error, failed to close output file ',outfile +endif + + +end program Index: trunk/LMDZ.TITAN.old/Tools/epflux.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/epflux.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/epflux.F90 (revision 1643) @@ -0,0 +1,458 @@ +subroutine epflux(iip1,jjp1,llm,indefini,latdeg,rbar & + ,teta,u3d,v3d,w3d,press & + ,epy2d,epz2d,divep2d,vtem2d,wtem2d,acc_meridien2d & +! ,vpupbar,wpupbar,vpvpbar,wpvpbar,vptetapbar,wptetapbar & + ) + + IMPLICIT NONE +!======================================================================= +! +! Audrey Crespin Sept 2007 +! +! source: Francois Forget Avril 1996 +! +! +! MODIF SLebonnois nov 2009 +! +! Cette subroutine Calcule Les flux d'Eliassen Palm a partir +! des composantes INTERPOLE EN NIVEAU DE PRESSION +! Toutes les variables sont sur la grille de pression press(1:llm) +! On suit la methode de Peixoto et Oort +! +! On est dans le plan meridien +! +! Calcule la divergence & composantes du flux d'EP +! Calcule la deviation a la circulation meridienne moyenne +! Calcule les TEM +! Calcule les termes de Reynolds +! +!======================================================================= +!----------------------------------------------------------------------- +! declarations: +! ------------- + +include "planet.h" + +! -------- +! ARGUMENTS +! --------- + +! Inputs: + + integer :: iip1,jjp1,llm + real :: indefini,latdeg(jjp1),rbar(jjp1,llm) + REAL :: teta(iip1,jjp1,llm) + REAL :: u3d(iip1,jjp1,llm),v3d(iip1,jjp1,llm) + REAL :: w3d(iip1,jjp1,llm) + REAL :: press(llm) + +! Outputs: + + REAL :: epy2d(jjp1,llm),epz2d(jjp1,llm),divep2d(jjp1,llm) + REAL :: vtem2d(jjp1,llm),wtem2d(jjp1,llm),acc_meridien2d(jjp1,llm) + REAL :: vpupbar(jjp1,llm),wpupbar(jjp1,llm) + REAL :: wpvpbar(jjp1,llm),vpvpbar(jjp1,llm) + REAL :: vptetapbar(jjp1,llm),wptetapbar(jjp1,llm) + +! Variables non zonales (vpup signifie : v^prim * u^prim) +! ------------------- + REAL :: vpup(iip1,jjp1,llm), wpup(iip1,jjp1,llm) + REAL :: vpvp(iip1,jjp1,llm), wpvp(iip1,jjp1,llm) + REAL :: vptetap(iip1,jjp1,llm), wptetap(iip1,jjp1,llm) + +! Moyennes zonales +! ------------- + REAL :: ubar(jjp1,llm),vbar(jjp1,llm),tetabar(jjp1,llm) + REAL :: wbar(jjp1,llm) + + + REAL :: dtetabardp(jjp1,llm),dubardp(jjp1,llm) + REAL :: vz(jjp1,llm),wlat(jjp1,llm),dvzdp(jjp1,llm) + REAL :: dwlatdlat(jjp1,llm) + + REAL :: depzdp(jjp1,llm) + +! Autres +! ------ + real :: rlatu(jjp1) ! lat in radians (beware of rounding effects at poles) + real :: pi + REAL :: tetas(llm) + logical :: peixoto + + REAL :: f(jjp1), ducosdlat(jjp1,llm) + REAL :: depycosdlat + INTEGER :: i,j,l, n, iim, jjm + +!----------------------------------------------------------------------- + + iim = iip1-1 + jjm = jjp1-1 + pi = 2.*asin(1.) + +! To avoid rounding effects at poles + rlatu(:)=latdeg(:)*pi/180.00001 + +! Calcul de moyennes zonales +! --------------------------- + call moyzon(iim,jjp1,llm,indefini,u3d,ubar) + call moyzon(iim,jjp1,llm,indefini,v3d,vbar) + call moyzon(iim,jjp1,llm,indefini,teta,tetabar) + call moyzon(iim,jjp1,llm,indefini,w3d,wbar) + + +! --*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*-- + peixoto = .false. + + if (peixoto) then + +! MODIF speciale Peixoto: on utilise la moyenne +! globale de teta: tetas(l) a la place de tetabar + do l=1,llm + tetas(l) = 0 + n= 0 + do j=2,jjm + if (tetabar(j,l).ne.indefini) then + tetas(l) = tetas(l) + tetabar(j,l) + n = n+1 + end if + end do + if (n.eq.0) stop 'bug dans elias ' + tetas(l) = tetas(l) / float(n) + + do j=1,jjp1 + tetabar(j,l) = tetas(l) + end do + end do +! write (*,*) 'tetas(l) ' , tetas +! write(*,*) + + endif +! --*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*-- + +! coriolis +! -------- + do j=1,jjp1 + f(j) = 2*omega*sin(rlatu(j)) + enddo + + +! Calcul des termes non zonaux +! ---------------------------- + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if (( v3d(i,j,l).eq.indefini).or. & + ( vbar(j,l).eq.indefini).or. & + ( teta(i,j,l).eq.indefini).or. & + (tetabar(j,l).eq.indefini)) then + vptetap(i,j,l)= indefini + else + vptetap(i,j,l)=(v3d(i,j,l)-vbar(j,l)) & + *(teta(i,j,l)-tetabar(j,l)) + end if + if (( w3d(i,j,l).eq.indefini).or. & + ( wbar(j,l).eq.indefini).or. & + ( teta(i,j,l).eq.indefini).or. & + (tetabar(j,l).eq.indefini)) then + wptetap(i,j,l)= indefini + else + wptetap(i,j,l)=(w3d(i,j,l)-wbar(j,l)) & + *(teta(i,j,l)-tetabar(j,l)) + end if + if ((v3d(i,j,l).eq.indefini).or. & + ( vbar(j,l).eq.indefini).or. & + (u3d(i,j,l).eq.indefini).or. & + ( ubar(j,l).eq.indefini)) then + vpup(i,j,l)= indefini + else + vpup(i,j,l)=(v3d(i,j,l)-vbar(j,l))*(u3d(i,j,l)-ubar(j,l)) + end if + if ((w3d(i,j,l).eq.indefini).or. & + ( wbar(j,l).eq.indefini).or. & + (u3d(i,j,l).eq.indefini).or. & + ( ubar(j,l).eq.indefini)) then + wpup(i,j,l)= indefini + else + wpup(i,j,l)=(w3d(i,j,l)-wbar(j,l))*(u3d(i,j,l)-ubar(j,l)) + end if + if ((v3d(i,j,l).eq.indefini).or. & + ( vbar(j,l).eq.indefini)) then + vpvp(i,j,l)= indefini + else + vpvp(i,j,l)=(v3d(i,j,l)-vbar(j,l))*(v3d(i,j,l)-vbar(j,l)) + end if + if ((w3d(i,j,l).eq.indefini).or. & + ( wbar(j,l).eq.indefini).or. & + (v3d(i,j,l).eq.indefini).or. & + ( vbar(j,l).eq.indefini)) then + wpvp(i,j,l)= indefini + else + wpvp(i,j,l)=(w3d(i,j,l)-wbar(j,l))*(v3d(i,j,l)-vbar(j,l)) + end if + end do + end do + end do + +! Moyennes zonales des termes non zonaux +! -------------------------------------- + +! Termes de Reynolds + +! flux zonaux de quantite de mouvement (vpupbar et wpupbar) +! flux meridiens de quantite de mouvement (vpvpbar et wpvpbar) +! flux meridien et vertical de chaleur (vptetapbar et wptetapbar) + + call moyzon(iim,jjp1,llm,indefini,vptetap,vptetapbar) + call moyzon(iim,jjp1,llm,indefini,wptetap,wptetapbar) + call moyzon(iim,jjp1,llm,indefini,vpup,vpupbar) + call moyzon(iim,jjp1,llm,indefini,wpup,wpupbar) + call moyzon(iim,jjp1,llm,indefini,vpvp,vpvpbar) + call moyzon(iim,jjp1,llm,indefini,wpvp,wpvpbar) + +! write(*,*) 'vptetapbar(2,23) =' , vptetapbar(2,23) +! write(*,*) 'wptetapbar(2,23) =' , wptetapbar(2,23) +! write(*,*) 'vpupbar(2,23) =' , vpupbar(2,23) + + +! Derivees d/dp des moyennes zonales +! -------------------------------------- + + call dx_dp(jjp1,llm,indefini,press,ubar,dubardp) + call dx_dp(jjp1,llm,indefini,press,tetabar,dtetabardp) +! write (*,*) 'dtetabardp(l) (K/Pa)',(dtetabardp(6,l),l=1,llm) +! write(*,*) + +! Controle (on triche !) de dtetabardp + do l=1,llm + do j=1,jjp1 + if ((dtetabardp(j,l).gt.-1.e-3).and. & + (dtetabardp(j,l).ne.indefini)) then + dtetabardp(j,l) = -1.e-3 +! write(*,*) 'profil presque instable en j = ',j,' l= ',l + end if + end do + end do +! write(*,*)'dtetabardp(l) (K/Pa) corr ',(dtetabardp(6,l),l=1,llm) +! write(*,*) + + +! calculs intermediaires +! ---------------------- + do l=1,llm + + if ((ubar(2,l).ne.indefini).and.(ubar(1,l).ne.indefini))then + ducosdlat(1,l) = ( ubar(2,l)*cos(rlatu(2))-ubar(1,l)*cos(rlatu(1)) ) & + /( rlatu(2) - rlatu(1)) + else + ducosdlat(1,l) = indefini + end if + do j=2,jjm + if ((ubar(j+1,l).ne.indefini).and.(ubar(j-1,l).ne.indefini))then + ducosdlat(j,l) = ( ubar(j+1,l)*cos(rlatu(j+1))-ubar(j-1,l)*cos(rlatu(j-1))) & + /( rlatu(j+1) - rlatu(j-1)) + else + ducosdlat(j,l) = indefini + end if + enddo + if ((ubar(jjp1,l).ne.indefini).and.(ubar(jjm,l).ne.indefini))then + ducosdlat(jjp1,l) = ( ubar(jjp1,l)*cos(rlatu(jjp1)) & + -ubar(jjm,l)*cos(rlatu(jjm)) ) & + /( rlatu(jjp1) - rlatu(jjm)) + else + ducosdlat(jjp1,l) = indefini + end if + + do j=1,jjp1 + if ((vptetapbar(j,l).ne.indefini).and. & + (dtetabardp(j,l).ne.indefini)) then + vz(j,l) = vptetapbar(j,l)/dtetabardp(j,l) + wlat(j,l) = cos(rlatu(j))*vz(j,l) + else + vz(j,l) = indefini + wlat(j,l) = indefini + end if + enddo + + enddo + +! Calcul des vecteurs flux Eliassen Palm et divergence +! ----------------------------------------------------- +! ref: Read 1986 + + do l=1,llm + epy2d(1,l) = indefini + epz2d(1,l) = indefini + do j=2,jjm + +! Composante y +! ------------ + + if ( (rbar(j,l).ne.indefini).and. & + (vpupbar(j,l).ne.indefini).and. & + (dubardp(j,l).ne.indefini).and. & + (vz(j,l).ne.indefini)) then + + epy2d(j,l) = rbar(j,l) * cos(rlatu(j))* ( vpupbar(j,l) & + - dubardp(j,l) * vz(j,l) & ! terme non geo + ) + +! if ((j.eq.1).and.(l.eq.23))write(*,*) 'epy2d(1,23) =' , epy2d(1,23) +! if ((j.eq.2).and.(l.eq.23))write(*,*) 'epy2d(2,23) =' , epy2d(2,23) +! if ((j.eq.3).and.(l.eq.23))write(*,*) 'epy2d(3,23) =' , epy2d(3,23) + else + epy2d(j,l) = indefini + end if + +! Composante z +! ------------ + + if ( (rbar(j,l).ne.indefini).and. & + (wpupbar(j,l).ne.indefini).and. & + (ducosdlat(j,l).ne.indefini).and. & + (vz(j,l).ne.indefini)) then + + epz2d(j,l) = rbar(j,l) * cos(rlatu(j))* & + ( vz(j,l) * ducosdlat(j,l)/(rbar(j,l)*cos(rlatu(j))) & ! terme non geo + - vz(j,l) * f(j) & + + wpupbar(j,l) & + ) + else + epz2d(j,l) = indefini + end if + +! if ((j.eq.2).and.(l.eq.23))write(*,*) 'epz2d(2,23) =' , epz2d(2,23) + end do + epy2d(jjp1,l) = indefini + epz2d(jjp1,l) = indefini + end do + +! Moyennes euleriennes transformees (vtem2d et wtem2d) +! ----------------------------------------------- + + call dx_dp(jjp1,llm,indefini,press,vz,dvzdp) + + do l=1,llm + + if ( (wlat(2,l).ne.indefini) .and. & + (wlat(1,l).ne.indefini) ) then + dwlatdlat(1,l)=(wlat(2,l)-wlat(1,l)) & + /(rlatu(2)-rlatu(1)) + else + dwlatdlat(1,l)=indefini + end if + do j=2,jjm + if ( (wlat(j+1,l).ne.indefini) .and. & + (wlat(j-1,l).ne.indefini) ) then + dwlatdlat(j,l)=(wlat(j+1,l)-wlat(j-1,l)) & + /(rlatu(j+1)-rlatu(j-1)) + else + dwlatdlat(j,l)=indefini + end if + enddo + if ( (wlat(jjp1,l).ne.indefini) .and. & + (wlat(jjm, l).ne.indefini) ) then + dwlatdlat(jjp1,l)=(wlat(jjp1,l)-wlat(jjm,l)) & + /(rlatu(jjp1)-rlatu(jjm)) + else + dwlatdlat(jjp1,l)=indefini + end if + + do j=1,jjp1 + if ( (dvzdp(j,l).ne.indefini) & + .and.(vbar(j,l).ne.indefini)) then + vtem2d(j,l) = vbar(j,l)-dvzdp(j,l) + else + vtem2d(j,l) = indefini + endif + enddo + + do j=1,jjp1 + if ( (rbar(j,l).ne.indefini).and. & + (dwlatdlat(j,l).ne.indefini).and. & + (wbar(j,l).ne.indefini)) then + wtem2d(j,l) = wbar(j,l)+dwlatdlat(j,l)/(rbar(j,l)*cos(rlatu(j))) + else + wtem2d(j,l) = indefini + endif + enddo + + enddo + +! write(*,*) 'vtem2d(2,23) =' , vtem2d(2,23) +! write(*,*) 'wtem2d(2,23) =' , wtem2d(2,23) + +! print*,"OK" + +! Deviation par rapport a la circulation meridienne moyenne +! -------------------------------------------------------- +! U*.Nabla ubar + do l=1,llm + do j=1,jjp1 + if ( (rbar(j,l).ne.indefini) & + .and.(vtem2d(j,l).ne.indefini) & + .and.(wtem2d(j,l).ne.indefini) & + .and.(ducosdlat(j,l).ne.indefini) & + .and.(dubardp(j,l).ne.indefini)) then + acc_meridien2d(j,l) = & + vtem2d(j,l)*(ducosdlat(j,l)/(rbar(j,l)*cos(rlatu(j))) & + -f(j)) & + + wtem2d(j,l)*dubardp(j,l) + else + acc_meridien2d(j,l) = indefini + endif + enddo + enddo + +! write(*,*) 'acc_meridien2d(2,23) =' , acc_meridien2d(2,23) + +! Divergence du flux +! ------------------ + call dx_dp(jjp1,llm,indefini,press,epz2d,depzdp) +! write(*,*) 'depzdp(2,23)',depzdp(j,l) + + do l=1,llm + divep2d(1,l) =0 + do j=2,jjm + if ( (rbar(j,l).ne.indefini) .and. & + (epy2d(j+1,l).ne.indefini) .and. & + (epy2d(j-1,l).ne.indefini) .and. & + (depzdp(j,l).ne.indefini) ) then + + depycosdlat=(epy2d(j+1,l)*cos(rlatu(j+1)) & + - epy2d(j-1,l)*cos(rlatu(j-1)) ) & + /(rlatu(j+1) - rlatu(j-1)) + +! DIVERGENCE DU FLUX : + + divep2d(j,l) = depycosdlat/(rbar(j,l)*cos(rlatu(j)))+depzdp(j,l) + +! if ((j.eq.2).and.(l.eq.23)) then +! write(*,*) 'depycosdlat(2,23)', depycosdlat +! write(*,*) 'depzdp(2,23)',depzdp(j,l) +! write(*,*) 'divergence(2,23)',divep2d(j,l) +! end if + +! Wave driving (Du/Dt et non Dm/dt) : + divep2d(j,l) = divep2d(j,l)/(rbar(j,l)*cos(rlatu(j))) + else + divep2d(j,l) = indefini + end if + end do + divep2d(jjp1,l) =0 + end do + +! write(*,*) ' fin :divep2d(2,23) =' , divep2d(2,23) + +! Preparation pour sortie graphique (flux ``chapeau'' Peixoto et Oort p 391) +! A VOIR... +! do l=1,llm +! do j=1,jjp1 +! if (epy2d(j,l).ne.indefini) & +! epy2d(j,l) = 2*pi*a0 *(1./g0)*cos(rlatu(j))*epy2d(j,l) +! if (epz2d(j,l).ne.indefini) & +! epz2d(j,l) = 2*pi*a0**2 *(1./g0)*cos(rlatu(j))*epz2d(j,l) +! end do +! end do + + return + end Index: trunk/LMDZ.TITAN.old/Tools/fft.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/fft.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/fft.F90 (revision 1643) @@ -0,0 +1,934 @@ +program fft + +! SL 01/2010: +! This program reads 4D (lon-lat-alt-time) fields recast in log P coordinates +! +! it computes fft of temperature, zonal and merid winds from high-frequency outputs: +! +! fftaT -- 4D -- FFT in amplitude of temperature field (K) +! fftau -- 4D -- FFT in amplitude of zonal wind (m s-1) +! fftav -- 4D -- FFT in amplitude of meridional wind (m s-1) +! ulf -- 4D -- low freq part of zonal wind perturbation uprim (m s-1) +! ubf -- 4D -- band freq part of zonal wind perturbation uprim (m s-1) +! uhf -- 4D -- high freq part of zonal wind perturbation uprim (m s-1) +! vlf -- 4D -- low freq part of meridional wind perturbation vprim (m s-1) +! vbf -- 4D -- band freq part of meridional wind perturbation vprim (m s-1) +! vhf -- 4D -- high freq part of meridional wind perturbation vprim (m s-1) +! wlf -- 4D -- low freq part of vertical wind perturbation wprim (Pa s-1) +! wbf -- 4D -- band freq part of vertical wind perturbation wprim (Pa s-1) +! whf -- 4D -- high freq part of vertical wind perturbation wprim (Pa s-1) +! Tlf -- 4D -- low freq part of temperature perturbation Tprim (K) +! Tbf -- 4D -- band freq part of temperature perturbation Tprim (K) +! Thf -- 4D -- high freq part of temperature perturbation Tprim (K) +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - pressure vertical coordinate +! - atmospheric temperature +! - zonal, meridional and vertical winds +! +! We use the FFTW library: http://www.fftw.org +! These routines are in C, but also include Fortran interfaces. +! +! Convention: qbar <=> zonal average / qstar = q - qbar +! qmean <=> temporal average / qprim = q - qmean +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FILTRES +!!!!!!!!!!!!!!!!!!!!!!!!!!! +! low frequencies: qlf= lowfreq(qprim) +! band frequencies: qbf=bandfreq(qprim) +! high frequencies: qhf=highfreq(qprim) +! +! Les frequences seuils sont ajustables dans filter.h +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile1,outfile2,outfile3,outfile4 ! output file names + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid1,outfid2,outfid3,outfid4 ! NetCDF output files ID +integer lon_dimid1,lat_dimid1,alt_dimid1,time_dimid1 ! NetCDF dimension IDs +integer lon_dimid2,lat_dimid2,alt_dimid2,time_dimid2 ! NetCDF dimension IDs +integer lon_dimid3,lat_dimid3,alt_dimid3,time_dimid3 ! NetCDF dimension IDs +integer lon_dimid4,lat_dimid4,alt_dimid4,time_dimid4 ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer :: datashape1d ! shape of 1D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along altitude (of input datasets) +real,dimension(:),allocatable :: time ! time +real,dimension(:),allocatable :: freq ! frequencies of the FFT (only timelength/2+1 values) +integer timelength ! # of points along time +real,dimension(:,:,:,:),allocatable :: temp ! atmospheric temperature +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitw ! vertical wind (in Pa/s) + +!!! output variables +real,dimension(:,:,:,:),allocatable :: fftaT ! FFT in amplitude of temperature (K) +real,dimension(:,:,:,:),allocatable :: fftau ! FFT in amplitude of zonal wind (m s-1) +real,dimension(:,:,:,:),allocatable :: fftav ! FFT in amplitude of meridional wind (m s-1) +real,dimension(:,:,:,:),allocatable :: fftaw ! FFT in amplitude of vertical wind (Pa s-1) +real,dimension(:,:,:,:),allocatable :: ulf ! low freq part of zonal wind perturbation uprim (m s-1) +real,dimension(:,:,:,:),allocatable :: ubf ! band freq part of zonal wind perturbation uprim (m s-1) +real,dimension(:,:,:,:),allocatable :: uhf ! high freq part of zonal wind perturbation uprim (m s-1) +real,dimension(:,:,:,:),allocatable :: vlf ! low freq part of meridional wind perturbation vprim (m s-1) +real,dimension(:,:,:,:),allocatable :: vbf ! band freq part of meridional wind perturbation vprim (m s-1) +real,dimension(:,:,:,:),allocatable :: vhf ! high freq part of meridional wind perturbation vprim (m s-1) +real,dimension(:,:,:,:),allocatable :: wlf ! low freq part of vertical wind perturbation vprim (Pa s-1) +real,dimension(:,:,:,:),allocatable :: wbf ! band freq part of vertical wind perturbation vprim (Pa s-1) +real,dimension(:,:,:,:),allocatable :: whf ! high freq part of vertical wind perturbation vprim (Pa s-1) +real,dimension(:,:,:,:),allocatable :: Tlf ! low freq part of temperature perturbation Tprim (K) +real,dimension(:,:,:,:),allocatable :: Tbf ! band freq part of temperature perturbation Tprim (K) +real,dimension(:,:,:,:),allocatable :: Thf ! high freq part of temperature perturbation Tprim (K) + +! local variables +real,dimension(:,:,:,:),allocatable :: uprim +real,dimension(:,:,:,:),allocatable :: vprim +real,dimension(:,:,:,:),allocatable :: wprim +real,dimension(:,:,:,:),allocatable :: Tprim + +! lon,lat,alt +real,dimension(:,:,:),allocatable :: umean +real,dimension(:,:,:),allocatable :: vmean +real,dimension(:,:,:),allocatable :: wmean +real,dimension(:,:,:),allocatable :: Tmean + +! for FFTW routines +real,dimension(:),allocatable :: wndow +double precision,dimension(:),allocatable :: var,fltvar +double complex,dimension(:),allocatable :: fftvar,fltfft +double complex,dimension(:),allocatable :: filtrelf,filtrebf,filtrehf +integer :: M_fft +integer*8 :: planf,planb + + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +logical flagfft +logical :: lmdflag + +! Tuning parameters +real :: fcoup1,fcoup2,width +real :: fcoup1tmp,fcoup2tmp,widthtmp +logical,dimension(4) :: ok_out +character (len=1) :: ok_outtmp + +include "planet.h" + +#include + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +! initialisation +!---------------- + +! Par defaut + +! Define the filters +! Low cutting frequency, in Hz : fcoup1 +fcoup1=2.5e-6 +! High cutting frequency, in Hz : fcoup2 +fcoup2=6.5e-6 +! Half-width of the filters, in Hz : width +width=4.e-7 +! Outputs (U, V, W, T) +ok_out=(/.true.,.true.,.false.,.true./) + +print*,"Low cutting frequency, in Hz ?" +print*,"between 1e-5 and 1e-7, 0 for default => 2.5e-6" +read(*,*) fcoup1tmp +if ((fcoup1tmp.lt.1e-5).and.(fcoup1tmp.gt.1e-7)) fcoup1=fcoup1tmp +print*,"=",fcoup1 +print*,"High cutting frequency, in Hz ?" +print*,"between 1e-5 and 1e-7, 0 for default => 6.5e-6" +read(*,*) fcoup2tmp +if ((fcoup2tmp.lt.1e-5).and.(fcoup2tmp.gt.1e-7)) fcoup2=fcoup2tmp +print*,"=",fcoup2 +print*,"Half-width of the filters, in Hz ?" +print*,"between 1e-6 and 1e-8, 0 for default => 4e-7)" +read(*,*) widthtmp +if ((widthtmp.lt.1e-6).and.(widthtmp.gt.1e-8)) width=widthtmp +print*,"=",width +!width = 3./time(timelength) + +! Outputs +print*,"Output of zonal wind ? (y or n, default is y)" +read(*,'(a1)') ok_outtmp +if (ok_outtmp.eq."n") ok_out(1)=.false. +print*,"=",ok_out(1) +print*,"Output of meridional wind ? (y or n, default is y)" +read(*,'(a1)') ok_outtmp +if (ok_outtmp.eq."n") ok_out(2)=.false. +print*,"=",ok_out(2) +print*,"Output of vertical wind ? (y or n, default is n)" +read(*,'(a1)') ok_outtmp +if (ok_outtmp.eq."y") ok_out(3)=.true. +print*,"=",ok_out(3) +print*,"Output of temperature ? (y or n, default is y)" +read(*,'(a1)') ok_outtmp +if (ok_outtmp.eq."n") ok_out(4)=.false. +print*,"=",ok_out(4) + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) " Program valid for files with pressure axis (*_P.nc)" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading altitude (ie pressure levels)" + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile1=infile(1:len_trim(infile)-3)//"_UFFT.nc" +outfile2=infile(1:len_trim(infile)-3)//"_VFFT.nc" +outfile3=infile(1:len_trim(infile)-3)//"_WFFT.nc" +outfile4=infile(1:len_trim(infile)-3)//"_TFFT.nc" +write(*,*) "Output file names are: " +if (ok_out(1)) write(*,*) trim(outfile1) +if (ok_out(2)) write(*,*) trim(outfile2) +if (ok_out(3)) write(*,*) trim(outfile3) +if (ok_out(4)) write(*,*) trim(outfile4) + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Atmospheric temperature +!=============================================================================== +if (ok_out(4)) then +allocate(temp(lonlength,latlength,altlength,timelength)) + +text="temp" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for t instead... " + text="t" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) then + print*,"Error: Failed to get temperature ID" + ok_out(4)=.false. + endif +endif +if (ierr2.ne.NF_NOERR) then + print*,"Error: Failed reading temperature" + ok_out(4)=.false. +endif +endif !ok_out(4) + +!=============================================================================== +! 2.1.2 Winds +!=============================================================================== +! zonal wind vitu (in m/s) +if (ok_out(1)) then +allocate(vitu(lonlength,latlength,altlength,timelength)) + +text="vitu" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + print*,"Error: Failed to get vitu ID" + ok_out(1)=.false. +endif +if (ierr2.ne.NF_NOERR) then + print*,"Error: Failed reading zonal wind" + ok_out(1)=.false. +endif +endif !ok_out(1) + +! meridional wind vitv (in m/s) +if (ok_out(2)) then +allocate(vitv(lonlength,latlength,altlength,timelength)) + +text="vitv" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + print*,"Error: Failed to get vitv ID" + ok_out(2)=.false. +endif +if (ierr2.ne.NF_NOERR) then + print*,"Error: Failed reading meridional wind" + ok_out(2)=.false. +endif +endif !ok_out(2) + +! vertical wind vitw (in Pa/s) +if (ok_out(3)) then +allocate(vitw(lonlength,latlength,altlength,timelength)) + +text="vitw" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitw,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + print*,"Error: Failed to get vitw ID" + ok_out(3)=.false. +endif +if (ierr2.ne.NF_NOERR) then + print*,"Error: Failed reading vertical wind" + ok_out(3)=.false. +endif +endif !ok_out(3) + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +print*,"debut calcul" + +!=============================================================================== +! 2.2.1 FFT and filtering +!=============================================================================== + +! allocations +!------------- +if (ok_out(1)) then +allocate(fftau(lonlength,latlength,altlength,timelength)) +allocate(uprim(lonlength,latlength,altlength,timelength)) +allocate(ulf(lonlength,latlength,altlength,timelength)) +allocate(ubf(lonlength,latlength,altlength,timelength)) +allocate(uhf(lonlength,latlength,altlength,timelength)) +endif !ok_out(1) +if (ok_out(2)) then +allocate(fftav(lonlength,latlength,altlength,timelength)) +allocate(vprim(lonlength,latlength,altlength,timelength)) +allocate(vlf(lonlength,latlength,altlength,timelength)) +allocate(vbf(lonlength,latlength,altlength,timelength)) +allocate(vhf(lonlength,latlength,altlength,timelength)) +endif !ok_out(2) +if (ok_out(3)) then +allocate(fftaw(lonlength,latlength,altlength,timelength)) +allocate(wprim(lonlength,latlength,altlength,timelength)) +allocate(wlf(lonlength,latlength,altlength,timelength)) +allocate(wbf(lonlength,latlength,altlength,timelength)) +allocate(whf(lonlength,latlength,altlength,timelength)) +endif !ok_out(3) +if (ok_out(4)) then +allocate(fftaT(lonlength,latlength,altlength,timelength)) +allocate(Tprim(lonlength,latlength,altlength,timelength)) +allocate(Tlf(lonlength,latlength,altlength,timelength)) +allocate(Tbf(lonlength,latlength,altlength,timelength)) +allocate(Thf(lonlength,latlength,altlength,timelength)) +endif !ok_out(4) + +! lon,lat,alt +if (ok_out(1)) allocate(umean(lonlength,latlength,altlength)) +if (ok_out(2)) allocate(vmean(lonlength,latlength,altlength)) +if (ok_out(3)) allocate(wmean(lonlength,latlength,altlength)) +if (ok_out(4)) allocate(Tmean(lonlength,latlength,altlength)) + +! time / frequencies +allocate(freq(timelength)) +allocate(wndow(timelength)) +allocate(var(timelength)) +allocate(fltvar(timelength)) +M_fft = timelength/2 +allocate(fftvar(M_fft+1)) +allocate(fltfft(M_fft+1)) +allocate(filtrelf(M_fft+1)) +allocate(filtrebf(M_fft+1)) +allocate(filtrehf(M_fft+1)) + +! intermediates +!----------------- + +if (ok_out(1)) call moytim(lonlength,latlength,altlength,timelength,miss_val,vitu,umean) +if (ok_out(2)) call moytim(lonlength,latlength,altlength,timelength,miss_val,vitv,vmean) +if (ok_out(3)) call moytim(lonlength,latlength,altlength,timelength,miss_val,vitw,wmean) +if (ok_out(4)) call moytim(lonlength,latlength,altlength,timelength,miss_val,temp,Tmean) + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + do itim=1,timelength +if (ok_out(1)) then + if ((vitu(ilon,ilat,ilev,itim).ne.miss_val).and. & + (umean(ilon,ilat,ilev) .ne.miss_val)) then + uprim(ilon,ilat,ilev,itim) = vitu(ilon,ilat,ilev,itim)-umean(ilon,ilat,ilev) + else + uprim(ilon,ilat,ilev,itim) = miss_val + endif +endif !ok_out(1) +if (ok_out(2)) then + if ((vitv(ilon,ilat,ilev,itim).ne.miss_val).and. & + (vmean(ilon,ilat,ilev) .ne.miss_val)) then + vprim(ilon,ilat,ilev,itim) = vitv(ilon,ilat,ilev,itim)-vmean(ilon,ilat,ilev) + else + vprim(ilon,ilat,ilev,itim) = miss_val + endif +endif !ok_out(2) +if (ok_out(3)) then + if ((vitw(ilon,ilat,ilev,itim).ne.miss_val).and. & + (wmean(ilon,ilat,ilev) .ne.miss_val)) then + wprim(ilon,ilat,ilev,itim) = vitw(ilon,ilat,ilev,itim)-wmean(ilon,ilat,ilev) + else + wprim(ilon,ilat,ilev,itim) = miss_val + endif +endif !ok_out(3) +if (ok_out(4)) then + if ((temp(ilon,ilat,ilev,itim).ne.miss_val).and. & + (Tmean(ilon,ilat,ilev) .ne.miss_val)) then + Tprim(ilon,ilat,ilev,itim) = temp(ilon,ilat,ilev,itim)-Tmean(ilon,ilat,ilev) + else + Tprim(ilon,ilat,ilev,itim) = miss_val + endif +endif !ok_out(4) + enddo + enddo + enddo +enddo ! lonlength + +! fft intermediates +!------------- + +! Define the frequencies +do itim=1,M_fft+1 + freq(itim) = (itim-1)/(timelength*(time(2)-time(1))) +enddo +do itim=M_fft+2,timelength + freq(itim) = 0. +enddo + +! Define the window (triangle) +do itim=1,timelength +! N window: +! wndow(itim)= 1. +! triangulaire de moyenne = 1 + wndow(itim)= 2.*(1. - abs(real(itim-0.5-M_fft)/real(M_fft))) +enddo + +do itim=1,M_fft+1 + if (freq(itim).lt.(fcoup1-width)) then + filtrelf(itim) = 1. + elseif (freq(itim).gt.(fcoup1+width)) then + filtrelf(itim) = 0. + else + filtrelf(itim) = (1.+sin(pi*(fcoup1-freq(itim))/(2.*width)))/2. + endif + if (freq(itim).lt.(fcoup2-width)) then + filtrehf(itim) = 0. + elseif (freq(itim).gt.(fcoup2+width)) then + filtrehf(itim) = 1. + else + filtrehf(itim) = (1.-sin(pi*(fcoup2-freq(itim))/(2.*width)))/2. + endif + filtrebf(itim) = (1.-filtrelf(itim))*(1.-filtrehf(itim)) +enddo + + +! fft and filtering +!------------- + +!---FFTW routines +call dfftw_plan_dft_r2c_1d(planf,timelength,var,fftvar,FFTW_MEASURE) +call dfftw_plan_dft_c2r_1d(planb,timelength,fltfft,fltvar,FFTW_MEASURE) +!--- + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + +! For zonal wind field +if (ok_out(1)) then + + flagfft=.true. + do itim=1,timelength + if (uprim(ilon,ilat,ilev,itim).eq.miss_val) flagfft=.false. + enddo + + if (flagfft) then + +! 1/ windowing to improve spectral analysis + var(:)=uprim(ilon,ilat,ilev,:)*wndow(:) +! 2/ FFT computation +!---FFTW routines + call dfftw_execute_dft_r2c(planf,var,fftvar) +!--- +! 3/ Amplitude of the FFT, for spectral analysis + fftau(ilon,ilat,ilev,1)=abs(fftvar(1))/M_fft + do itim=2,M_fft + fftau(ilon,ilat,ilev,itim) = abs(fftvar(itim))/M_fft + enddo + fftau(ilon,ilat,ilev,M_fft+1)=abs(fftvar(M_fft+1))/M_fft + do itim=M_fft+2,timelength + fftau(ilon,ilat,ilev,itim) = 0. + enddo + +! 4/ filtering the FFT in three regions +! filtering + normalisation (low freq) + fltfft(:) = fftvar(:)*filtrelf(:)/timelength +! 5/ backward FFT for each region +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- +! 6/ reverse the windowing + ulf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (band freq) + fltfft(:) = fftvar(:)*filtrebf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + ubf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (high freq) + fltfft(:) = fftvar(:)*filtrehf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + uhf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + + else + fftau(ilon,ilat,ilev,itim) = miss_val + ulf(ilon,ilat,ilev,itim) = miss_val + ubf(ilon,ilat,ilev,itim) = miss_val + uhf(ilon,ilat,ilev,itim) = miss_val + endif ! flagfft + +endif !ok_out(1) + +! For meridional wind wind field +if (ok_out(2)) then + + flagfft=.true. + do itim=1,timelength + if (vprim(ilon,ilat,ilev,itim).eq.miss_val) flagfft=.false. + enddo + + if (flagfft) then + +! 1/ windowing to improve spectral analysis + var(:)=vprim(ilon,ilat,ilev,:)*wndow(:) +! 2/ FFT computation +!---FFTW routines + call dfftw_execute_dft_r2c(planf,var,fftvar) +!--- +! 3/ Amplitude of the FFT, for spectral analysis + fftav(ilon,ilat,ilev,1)=abs(fftvar(1))/M_fft + do itim=2,M_fft + fftav(ilon,ilat,ilev,itim) = abs(fftvar(itim))/M_fft + enddo + fftav(ilon,ilat,ilev,M_fft+1)=abs(fftvar(M_fft+1))/M_fft + do itim=M_fft+2,timelength + fftav(ilon,ilat,ilev,itim) = 0. + enddo + +! 4/ filtering the FFT in three regions +! filtering + normalisation (low freq) + fltfft(:) = fftvar(:)*filtrelf(:)/timelength +! 5/ backward FFT for each region +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- +! 6/ reverse the windowing + vlf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (band freq) + fltfft(:) = fftvar(:)*filtrebf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + vbf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (high freq) + fltfft(:) = fftvar(:)*filtrehf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + vhf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + + else + fftav(ilon,ilat,ilev,itim) = miss_val + vlf(ilon,ilat,ilev,itim) = miss_val + vbf(ilon,ilat,ilev,itim) = miss_val + vhf(ilon,ilat,ilev,itim) = miss_val + endif ! flagfft + +endif !ok_out(2) + +! For vertical wind wind field +if (ok_out(3)) then + + flagfft=.true. + do itim=1,timelength + if (wprim(ilon,ilat,ilev,itim).eq.miss_val) flagfft=.false. + enddo + + if (flagfft) then + +! 1/ windowing to improve spectral analysis + var(:)=wprim(ilon,ilat,ilev,:)*wndow(:) +! 2/ FFT computation +!---FFTW routines + call dfftw_execute_dft_r2c(planf,var,fftvar) +!--- +! 3/ Amplitude of the FFT, for spectral analysis + fftaw(ilon,ilat,ilev,1)=abs(fftvar(1))/M_fft + do itim=2,M_fft + fftaw(ilon,ilat,ilev,itim) = abs(fftvar(itim))/M_fft + enddo + fftaw(ilon,ilat,ilev,M_fft+1)=abs(fftvar(M_fft+1))/M_fft + do itim=M_fft+2,timelength + fftaw(ilon,ilat,ilev,itim) = 0. + enddo + +! 4/ filtering the FFT in three regions +! filtering + normalisation (low freq) + fltfft(:) = fftvar(:)*filtrelf(:)/timelength +! 5/ backward FFT for each region +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- +! 6/ reverse the windowing + wlf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (band freq) + fltfft(:) = fftvar(:)*filtrebf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + wbf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (high freq) + fltfft(:) = fftvar(:)*filtrehf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + whf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + + else + fftaw(ilon,ilat,ilev,itim) = miss_val + wlf(ilon,ilat,ilev,itim) = miss_val + wbf(ilon,ilat,ilev,itim) = miss_val + whf(ilon,ilat,ilev,itim) = miss_val + endif ! flagfft + +endif !ok_out(3) + +! For temperature field +if (ok_out(4)) then + + flagfft=.true. + do itim=1,timelength + if (Tprim(ilon,ilat,ilev,itim).eq.miss_val) flagfft=.false. + enddo + + if (flagfft) then + +! 1/ windowing to improve spectral analysis + var(:)=Tprim(ilon,ilat,ilev,:)*wndow(:) +! 2/ FFT computation +!---FFTW routines + call dfftw_execute_dft_r2c(planf,var,fftvar) +!--- +! 3/ Amplitude of the FFT, for spectral analysis + fftaT(ilon,ilat,ilev,1)=abs(fftvar(1))/M_fft + do itim=2,M_fft + fftaT(ilon,ilat,ilev,itim) = abs(fftvar(itim))/M_fft + enddo + fftaT(ilon,ilat,ilev,M_fft+1)=abs(fftvar(M_fft+1))/M_fft + do itim=M_fft+2,timelength + fftaT(ilon,ilat,ilev,itim) = 0. + enddo + +! 4/ filtering the FFT in three regions +! filtering + normalisation (low freq) + fltfft(:) = fftvar(:)*filtrelf(:)/timelength +! 5/ backward FFT for each region +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- +! 6/ reverse the windowing + Tlf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (band freq) + fltfft(:) = fftvar(:)*filtrebf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + Tbf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + +! filtering + normalisation (high freq) + fltfft(:) = fftvar(:)*filtrehf(:)/timelength +!---FFTW routines + call dfftw_execute_dft_c2r(planb,fltfft,fltvar) +!--- + Thf(ilon,ilat,ilev,:) = fltvar(:)/wndow(:) + + else + fftaT(ilon,ilat,ilev,itim) = miss_val + Tlf(ilon,ilat,ilev,itim) = miss_val + Tbf(ilon,ilat,ilev,itim) = miss_val + Thf(ilon,ilat,ilev,itim) = miss_val + endif ! flagfft + +endif !ok_out(4) + + enddo + enddo +enddo ! lonlength + +!---FFTW routines +call dfftw_destroy_plan(planf) +call dfftw_destroy_plan(planb) +!--- + +print*,"End of computations" + +!=============================================================================== +! 3. Create output files +!=============================================================================== + +! Create output files +if (ok_out(1)) then +ierr=NF_CREATE(outfile1,NF_CLOBBER,outfid1) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile1 + stop +endif +endif !ok_out(1) + +if (ok_out(2)) then +ierr=NF_CREATE(outfile2,NF_CLOBBER,outfid2) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile2 + stop +endif +endif !ok_out(2) + +if (ok_out(3)) then +ierr=NF_CREATE(outfile3,NF_CLOBBER,outfid3) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile3 + stop +endif +endif !ok_out(3) + +if (ok_out(4)) then +ierr=NF_CREATE(outfile4,NF_CLOBBER,outfid4) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile4 + stop +endif +endif !ok_out(4) + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +if (ok_out(1)) & +call write_dim(outfid1,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid1,lat_dimid1,alt_dimid1,time_dimid1) +if (ok_out(2)) & +call write_dim(outfid2,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid2,lat_dimid2,alt_dimid2,time_dimid2) +if (ok_out(3)) & +call write_dim(outfid3,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid3,lat_dimid3,alt_dimid3,time_dimid3) +if (ok_out(4)) & +call write_dim(outfid4,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid4,lat_dimid4,alt_dimid4,time_dimid4) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +if (ok_out(1)) then + +datashape4d(1)=lon_dimid1 +datashape4d(2)=lat_dimid1 +datashape4d(3)=alt_dimid1 +datashape4d(4)=time_dimid1 +datashape1d =time_dimid1 + +call write_var1d(outfid1,datashape1d,timelength,& + "freq ", "FFT frequencies ","s-1 ",miss_val,& + freq ) + +call write_var4d(outfid1,datashape4d,lonlength,latlength,altlength,timelength,& + "fftau ", "FFT ampl of vitu ","m s-1 ",miss_val,& + fftau ) + +call write_var4d(outfid1,datashape4d,lonlength,latlength,altlength,timelength,& + "ulf ", "low freq part vitu ","m s-1 ",miss_val,& + ulf ) + +call write_var4d(outfid1,datashape4d,lonlength,latlength,altlength,timelength,& + "ubf ", "band freq part vitu ","m s-1 ",miss_val,& + ubf ) + +call write_var4d(outfid1,datashape4d,lonlength,latlength,altlength,timelength,& + "uhf ", "high freq part vitu ","m s-1 ",miss_val,& + uhf ) +endif !ok_out(1) + +if (ok_out(2)) then + +datashape4d(1)=lon_dimid2 +datashape4d(2)=lat_dimid2 +datashape4d(3)=alt_dimid2 +datashape4d(4)=time_dimid2 +datashape1d =time_dimid2 + +call write_var1d(outfid2,datashape1d,timelength,& + "freq ", "FFT frequencies ","s-1 ",miss_val,& + freq ) + +call write_var4d(outfid2,datashape4d,lonlength,latlength,altlength,timelength,& + "fftav ", "FFT ampl of vitv ","m s-1 ",miss_val,& + fftav ) + +call write_var4d(outfid2,datashape4d,lonlength,latlength,altlength,timelength,& + "vlf ", "low freq part vitv ","m s-1 ",miss_val,& + vlf ) + +call write_var4d(outfid2,datashape4d,lonlength,latlength,altlength,timelength,& + "vbf ", "band freq part vitv ","m s-1 ",miss_val,& + vbf ) + +call write_var4d(outfid2,datashape4d,lonlength,latlength,altlength,timelength,& + "vhf ", "high freq part vitv ","m s-1 ",miss_val,& + vhf ) +endif !ok_out(2) + +if (ok_out(3)) then + +datashape4d(1)=lon_dimid3 +datashape4d(2)=lat_dimid3 +datashape4d(3)=alt_dimid3 +datashape4d(4)=time_dimid3 +datashape1d =time_dimid3 + +call write_var1d(outfid3,datashape1d,timelength,& + "freq ", "FFT frequencies ","s-1 ",miss_val,& + freq ) + +call write_var4d(outfid3,datashape4d,lonlength,latlength,altlength,timelength,& + "fftaw ", "FFT ampl of vitw ","Pa s-1 ",miss_val,& + fftaw ) + +call write_var4d(outfid3,datashape4d,lonlength,latlength,altlength,timelength,& + "wlf ", "low freq part vitw ","Pa s-1 ",miss_val,& + wlf ) + +call write_var4d(outfid3,datashape4d,lonlength,latlength,altlength,timelength,& + "wbf ", "band freq part vitw ","Pa s-1 ",miss_val,& + wbf ) + + call write_var4d(outfid3,datashape4d,lonlength,latlength,altlength,timelength,& + "whf ", "high freq part vitw ","Pa s-1 ",miss_val,& + whf ) +endif !ok_out(3) + +if (ok_out(4)) then + +datashape4d(1)=lon_dimid4 +datashape4d(2)=lat_dimid4 +datashape4d(3)=alt_dimid4 +datashape4d(4)=time_dimid4 +datashape1d =time_dimid4 + +call write_var1d(outfid4,datashape1d,timelength,& + "freq ", "FFT frequencies ","s-1 ",miss_val,& + freq ) + +call write_var4d(outfid4,datashape4d,lonlength,latlength,altlength,timelength,& + "fftaT ", "FFT ampl of temp ","K ",miss_val,& + fftaT ) + +call write_var4d(outfid4,datashape4d,lonlength,latlength,altlength,timelength,& + "tlf ", "low freq part temp ","K ",miss_val,& + Tlf ) + +call write_var4d(outfid4,datashape4d,lonlength,latlength,altlength,timelength,& + "tbf ", "band freq part temp ","K ",miss_val,& + Tbf ) + +call write_var4d(outfid4,datashape4d,lonlength,latlength,altlength,timelength,& + "thf ", "high freq part temp ","K ",miss_val,& + Thf ) +endif !ok_out(4) + +!!!! Close output files +if (ok_out(1)) then +ierr=NF_CLOSE(outfid1) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile1 +endif !ok_out(1) + +if (ok_out(2)) then +ierr=NF_CLOSE(outfid2) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile2 +endif !ok_out(2) + +if (ok_out(3)) then +ierr=NF_CLOSE(outfid3) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile3 +endif !ok_out(3) + +if (ok_out(4)) then +ierr=NF_CLOSE(outfid4) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile4 +endif !ok_out(4) + + +end program Index: trunk/LMDZ.TITAN.old/Tools/filter.h =================================================================== --- trunk/LMDZ.TITAN.old/Tools/filter.h (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/filter.h (revision 1643) @@ -0,0 +1,15 @@ +! Tuning parameters for fft.F90 + +! Low cutting frequency, in Hz : fcoup1 + real, parameter :: fcoup1=1.e-6 + +! High cutting frequency, in Hz : fcoup2 + real, parameter :: fcoup2=3.5e-6 + +! Half-width of the filters, in Hz : width + real, parameter :: width=4.e-7 + +! Choice of output files: +! (U, V, W, T) + logical,dimension(4) :: ok_out=(/.true.,.true.,.false.,.true./) + Index: trunk/LMDZ.TITAN.old/Tools/io.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/io.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/io.F90 (revision 1643) @@ -0,0 +1,683 @@ +subroutine get_iddim(infid,latid,latlength,lonid,lonlength, & + altid,altlength,timid,timelength,lmdflag ) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer infid ! NetCDF input file ID +integer lonid,latid,altid,timid +integer lonlength ! # of grid points along longitude +integer latlength ! # of grid points along latitude +integer altlength ! # of grid point along altitude (of input datasets) +integer timelength ! # of points along time +logical lmdflag ! true=LMD, false=CAM + +!local +integer tmpdimid ! temporarily store a dimension ID +integer ierr ! NetCDF routines return code + +! latitude +ierr=NF_INQ_DIMID(infid,"latitude",tmpdimid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get latitude dimension ID" + write(*,*) " looking for lat dimension instead... " + ierr=NF_INQ_DIMID(infid,"lat",tmpdimid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lat dimension ID" + else + ierr=NF_INQ_VARID(infid,"lat",latid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lat ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,latlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get lat length" + endif + endif +else + ierr=NF_INQ_VARID(infid,"latitude",latid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get latitude ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,latlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get latitude length" + endif +endif + +! longitude +ierr=NF_INQ_DIMID(infid,"longitude",tmpdimid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get longitude dimension ID" + write(*,*) " looking for lon dimension instead... " + ierr=NF_INQ_DIMID(infid,"lon",tmpdimid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lon dimension ID" + else + ierr=NF_INQ_VARID(infid,"lon",lonid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lon ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,lonlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get lon length" + endif + endif +else + ierr=NF_INQ_VARID(infid,"longitude",lonid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get longitude ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,lonlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get longitude length" + endif +endif + +lmdflag=.true. +! altitude : pressure levels +ierr=NF_INQ_DIMID(infid,"altitude",tmpdimid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get altitude dimension ID" + write(*,*) " looking for presnivs dimension instead... " + ierr=NF_INQ_DIMID(infid,"presnivs",tmpdimid) + if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get presnivs dimension ID" + write(*,*) " looking for lev dimension instead... " + ierr=NF_INQ_DIMID(infid,"lev",tmpdimid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lev dimension ID" + else + ierr=NF_INQ_VARID(infid,"lev",altid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get lev ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,altlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get lev length" + lmdflag=.false. + endif + endif + else + ierr=NF_INQ_VARID(infid,"presnivs",altid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get presnivs ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,altlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get presnivs length" + endif + endif +else + ierr=NF_INQ_VARID(infid,"altitude",altid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get altitude ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,altlength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get altitude length" + endif +endif + +! time +ierr=NF_INQ_DIMID(infid,"Time",tmpdimid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get Time dimension ID" + write(*,*) " looking for time dimension instead... " + ierr=NF_INQ_DIMID(infid,"time",tmpdimid) + if (ierr.ne.NF_NOERR) then + write(*,*) "Could not get time dimension ID" + write(*,*) " looking for time_counter dimension instead... " + ierr=NF_INQ_DIMID(infid,"time_counter",tmpdimid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get time_counter dimension ID" + else + ierr=NF_INQ_VARID(infid,"time_counter",timid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get time_counter ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,timelength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get time_counter length" + endif + endif + else + ierr=NF_INQ_VARID(infid,"time",timid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get time ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,timelength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get time length" + endif + endif +else + ierr=NF_INQ_VARID(infid,"Time",timid) + if (ierr.ne.NF_NOERR) then + stop "Error: Failed to get Time ID" + else + ierr=NF_INQ_DIMLEN(infid,tmpdimid,timelength) + if (ierr.ne.NF_NOERR) stop "Error: Failed to get Time length" + endif +endif + +return +end + +!=========================================================================== + +subroutine get_var2d(infid,dim1,dim2,text,var,ierr1,ierr2) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: infid ! NetCDF input file ID +integer :: dim1,dim2 ! dim length of the 3D variable +character (len=64) :: text ! name of variable to read +real,dimension(dim1,dim2) :: var ! variable to read +integer :: ierr1,ierr2 ! NetCDF routines return code + +! local +integer tmpvarid ! temporarily store a variable ID + +ierr1=NF_INQ_VARID(infid,trim(text),tmpvarid) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Could not get ID for ",trim(text) +else + write(*,*) "ID ok for ",trim(text) + ierr2=NF_GET_VAR_REAL(infid,tmpvarid,var) +endif + +return +end + +!=========================================================================== + +subroutine get_var3d(infid,dim1,dim2,dim3,text,var,ierr1,ierr2) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: infid ! NetCDF input file ID +integer :: dim1,dim2,dim3 ! dim length of the 3D variable +character (len=64) :: text ! name of variable to read +real,dimension(dim1,dim2,dim3) :: var ! variable to read +integer :: ierr1,ierr2 ! NetCDF routines return code + +! local +integer tmpvarid ! temporarily store a variable ID + +ierr1=NF_INQ_VARID(infid,trim(text),tmpvarid) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Could not get ID for ",trim(text) +else + write(*,*) "ID ok for ",trim(text) + ierr2=NF_GET_VAR_REAL(infid,tmpvarid,var) +endif + +return +end + +!=========================================================================== + +subroutine get_var4d(infid,dim1,dim2,dim3,dim4,text,var,missing,ierr1,ierr2) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: infid ! NetCDF input file ID +integer :: dim1,dim2,dim3,dim4 ! dim length of the 4D variable +character (len=64) :: text ! name of variable to read +real,dimension(dim1,dim2,dim3,dim4) :: var ! variable to read +real :: missing ! missing value +integer :: ierr1,ierr2,miss ! NetCDF routines return code + +! local +integer tmpvarid ! temporarily store a variable ID + +ierr1=NF_INQ_VARID(infid,trim(text),tmpvarid) +if (ierr1.ne.NF_NOERR) then + write(*,*) "Could not get ID for ",trim(text) +else + write(*,*) "ID ok for ",trim(text) + ierr2=NF_GET_VAR_REAL(infid,tmpvarid,var) + miss=NF_GET_ATT_REAL(infid,tmpvarid,"missing_value",missing) +endif + +return +end + +!=========================================================================== + +subroutine write_dim(outfid,dim1,dim2,dim3,dim4,lon,lat,plev,time,& + lon_dimid,lat_dimid,alt_dimid,time_dimid) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: outfid ! NetCDF output file ID +integer :: dim1,dim2,dim3,dim4 ! dim length of the 4D variable +real,dimension(dim1) :: lon ! longitude +real,dimension(dim2) :: lat ! latitude +real,dimension(dim3) :: plev ! Pressure levels (Pa) +real,dimension(dim4) :: time ! time +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs + +! local +integer lon_varid,lat_varid,alt_varid,time_varid +character (len=64) :: text ! to store some text +integer ierr ! NetCDF routines return code + + +!------------ +! longitude +!------------ + +ierr=NF_DEF_DIM(outfid,"longitude",dim1,lon_dimid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define longitude dimension" + +ierr=NF_DEF_VAR(outfid,"longitude",NF_REAL,1,lon_dimid,lon_varid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define longitude variable" + +! longitude attributes +text='east longitude' +ierr=NF_PUT_ATT_TEXT(outfid,lon_varid,'long_name',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing long_name for longitude" + +text='degrees_east' +ierr=NF_PUT_ATT_TEXT(outfid,lon_varid,'units',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing units for longitude" + +!------------ +! latitude +!------------ + +ierr=NF_DEF_DIM(outfid,"latitude",dim2,lat_dimid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define latitude dimension" + +ierr=NF_DEF_VAR(outfid,"latitude",NF_REAL,1,lat_dimid,lat_varid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define latitude variable" + +! latitude attributes +text='north latitude' +ierr=NF_PUT_ATT_TEXT(outfid,lat_varid,'long_name',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing long_name for latitude" + +text='degrees_north' +ierr=NF_PUT_ATT_TEXT(outfid,lat_varid,'units',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing units for latitude" + +!------------ +! pressure +!------------ + +ierr=NF_DEF_DIM(outfid,"presnivs",dim3,alt_dimid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define presnivs dimension" + +ierr=NF_DEF_VAR(outfid,"presnivs",NF_REAL,1,alt_dimid,alt_varid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define presnivs variable" + +!presnivs attributes +text='Pressure levels' +ierr=NF_PUT_ATT_TEXT(outfid,alt_varid,'long_name',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing long_name for presnivs (p levels)" + +text='Pa' +ierr=NF_PUT_ATT_TEXT(outfid,alt_varid,'units',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing units for presnivs (p levels)" + +text='down' +ierr=NF_PUT_ATT_TEXT(outfid,alt_varid,'positive',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing positive for presnivs (p levels)" + +!------------ +! time +!------------ + +ierr=NF_DEF_DIM(outfid,"Time",dim4,time_dimid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define time dimension" + +ierr=NF_DEF_VAR(outfid,"Time",NF_REAL,1,time_dimid,time_varid) +if (ierr.ne.NF_NOERR) stop "Error: Could not define Time variable" + +! time attributes +text='Time' +ierr=NF_PUT_ATT_TEXT(outfid,time_varid,'long_name',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing long_name for Time" + +text='days since 0000-01-1 00:00:00' +ierr=NF_PUT_ATT_TEXT(outfid,time_varid,'units',len_trim(text),text) +if (ierr.ne.NF_NOERR) stop "Error: Problem writing units for Time" + +print*,"End of dim definitions" + +!------------ +! Switch out of NetCDF define mode +!------------ +ierr=NF_ENDDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch out of define mode" + +! Write longitude +ierr=NF_PUT_VAR_REAL(outfid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Could not write longitude data to output file" + +! Write latitude +ierr=NF_PUT_VAR_REAL(outfid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Could not write latitude data to output file" + +! Write pressure +ierr=NF_PUT_VAR_REAL(outfid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Could not write presnivs data to output file" + +! Write time +ierr=NF_PUT_VAR_REAL(outfid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Could not write Time data to output file" + +print*,"Writing dim OK" + +return +end + + +!=========================================================================== + +subroutine write_var1d(outfid,datashape,dim1,& + name,lgname,units,miss_val,var) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: outfid ! NetCDF output file ID +integer :: dim1 ! dim length of the 1D variable +integer :: datashape ! shape of datasets +character (len=10) :: name ! name of variable +character (len=20) :: lgname ! long name of variable +character (len=10) :: units ! unit of variable +real :: miss_val ! "missing value" to specify missing data +real,dimension(dim1) :: var ! variable to read + +! local +character (len=64) :: text ! to store some text +integer ierr ! NetCDF routines return code +integer varid + +!------------ +! Define variable +!------------ + +ierr=NF_REDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch into define mode" + +ierr=NF_DEF_VAR(outfid,trim(name),NF_REAL,1,datashape,varid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not define variable : ",name + stop +endif + +! attributes +ierr=NF_PUT_ATT_TEXT(outfid,varid,'long_name',len_trim(lgname),lgname) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing long_name for ",name + stop +endif + +ierr=NF_PUT_ATT_TEXT(outfid,varid,'units',len_trim(units),units) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing units for ",name + stop +endif + +ierr=NF_PUT_ATT_REAL(outfid,varid,'missing_value',NF_REAL,1,miss_val) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: failed to write missing_value for ",name + stop +endif + +print*,"End of var def : ",name + +!------------ +! Switch out of NetCDF define mode +!------------ +ierr=NF_ENDDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch out of define mode" + +ierr=NF_PUT_VAR_REAL(outfid,varid,var) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not write var ",name + stop +endif + +print*,"Writing var OK : ",name + +return +end + +!=========================================================================== + +subroutine write_var2d(outfid,datashape,dim1,dim2,& + name,lgname,units,miss_val,var) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: outfid ! NetCDF output file ID +integer :: dim1,dim2 ! dim length of the 2D variable +integer,dimension(2) :: datashape ! shape of datasets +character (len=10) :: name ! name of variable +character (len=20) :: lgname ! long name of variable +character (len=10) :: units ! unit of variable +real :: miss_val ! "missing value" to specify missing data +real,dimension(dim1,dim2) :: var ! variable to read + +! local +character (len=64) :: text ! to store some text +integer ierr ! NetCDF routines return code +integer varid + +!------------ +! Define variable +!------------ + +ierr=NF_REDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch into define mode" + +ierr=NF_DEF_VAR(outfid,trim(name),NF_REAL,2,datashape,varid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not define variable : ",name + stop +endif + +! attributes +ierr=NF_PUT_ATT_TEXT(outfid,varid,'long_name',len_trim(lgname),lgname) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing long_name for ",name + stop +endif + +ierr=NF_PUT_ATT_TEXT(outfid,varid,'units',len_trim(units),units) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing units for ",name + stop +endif + +ierr=NF_PUT_ATT_REAL(outfid,varid,'missing_value',NF_REAL,1,miss_val) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: failed to write missing_value for ",name + stop +endif + +print*,"End of var def : ",name + +!------------ +! Switch out of NetCDF define mode +!------------ +ierr=NF_ENDDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch out of define mode" + +ierr=NF_PUT_VAR_REAL(outfid,varid,var) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not write var ",name + stop +endif + +print*,"Writing var OK : ",name + +return +end + +!=========================================================================== + +subroutine write_var3d(outfid,datashape,dim1,dim2,dim3,& + name,lgname,units,miss_val,var) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: outfid ! NetCDF output file ID +integer :: dim1,dim2,dim3 ! dim length of the 3D variable +integer,dimension(3) :: datashape ! shape of datasets +character (len=10) :: name ! name of variable +character (len=20) :: lgname ! long name of variable +character (len=10) :: units ! unit of variable +real :: miss_val ! "missing value" to specify missing data +real,dimension(dim1,dim2,dim3) :: var ! variable to read + +! local +character (len=64) :: text ! to store some text +integer ierr ! NetCDF routines return code +integer varid + +!------------ +! Define variable +!------------ + +ierr=NF_REDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch into define mode" + +ierr=NF_DEF_VAR(outfid,trim(name),NF_REAL,3,datashape,varid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not define variable : ",name + stop +endif + +! attributes +ierr=NF_PUT_ATT_TEXT(outfid,varid,'long_name',len_trim(lgname),lgname) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing long_name for ",name + stop +endif + +ierr=NF_PUT_ATT_TEXT(outfid,varid,'units',len_trim(units),units) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing units for ",name + stop +endif + +ierr=NF_PUT_ATT_REAL(outfid,varid,'missing_value',NF_REAL,1,miss_val) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: failed to write missing_value for ",name + stop +endif + +print*,"End of var def : ",name + +!------------ +! Switch out of NetCDF define mode +!------------ +ierr=NF_ENDDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch out of define mode" + +ierr=NF_PUT_VAR_REAL(outfid,varid,var) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not write var ",name + stop +endif + +print*,"Writing var OK : ",name + +return +end + +!=========================================================================== + +subroutine write_var4d(outfid,datashape,dim1,dim2,dim3,dim4,& + name,lgname,units,miss_val,var) + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +! arguments +integer :: outfid ! NetCDF output file ID +integer :: dim1,dim2,dim3,dim4 ! dim length of the 4D variable +integer,dimension(4) :: datashape ! shape of datasets +character (len=10) :: name ! name of variable +character (len=20) :: lgname ! long name of variable +character (len=10) :: units ! unit of variable +real :: miss_val ! "missing value" to specify missing data +real,dimension(dim1,dim2,dim3,dim4) :: var ! variable to read + +! local +character (len=64) :: text ! to store some text +integer ierr ! NetCDF routines return code +integer varid + +!------------ +! Define variable +!------------ + +ierr=NF_REDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch into define mode" + +ierr=NF_DEF_VAR(outfid,trim(name),NF_REAL,4,datashape,varid) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not define variable : ",name + stop +endif + +! attributes +ierr=NF_PUT_ATT_TEXT(outfid,varid,'long_name',len_trim(lgname),lgname) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing long_name for ",name + stop +endif + +ierr=NF_PUT_ATT_TEXT(outfid,varid,'units',len_trim(units),units) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Problem writing units for ",name + stop +endif + +ierr=NF_PUT_ATT_REAL(outfid,varid,'missing_value',NF_REAL,1,miss_val) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: failed to write missing_value for ",name + stop +endif + +print*,"End of var def : ",name + +!------------ +! Switch out of NetCDF define mode +!------------ +ierr=NF_ENDDEF(outfid) +if (ierr.ne.NF_NOERR) stop "Error: Could not switch out of define mode" + +ierr=NF_PUT_VAR_REAL(outfid,varid,var) +if (ierr.ne.NF_NOERR) then + write(*,*) "Error: Could not write var ",name + stop +endif + +print*,"Writing var OK : ",name + +return +end + + Index: trunk/LMDZ.TITAN.old/Tools/moytim.F =================================================================== --- trunk/LMDZ.TITAN.old/Tools/moytim.F (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/moytim.F (revision 1643) @@ -0,0 +1,50 @@ + SUBROUTINE moytim(iim,jjp1,nl,nt,indefini,x,xmean) +c======================================================================= +c +c +c Subject: +c ------ +c Calcul de la moyenne zonale de la variable au point scalaire x +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +c Arguments: +c ---------- + + INTEGER iim,jjp1,nl,nt + real indefini + REAL x(iim,jjp1,nl,nt) + REAL xmean(iim,jjp1,nl) + +c Local: +c ------ + + iNTEGER i,j,l,t , n + +c------------------------------------------------------------------------ + do l=1,nl + do j=1,jjp1 + do i=1,iim + xmean(i,j,l)=0. + n = 0 + do t=1,nt + if (x(i,j,l,t).ne.indefini) then + xmean(i,j,l) = xmean(i,j,l) + x(i,j,l,t) + n = n+1 + end if + end do + if (n.ne.0) then + xmean(i,j,l) = xmean(i,j,l)/float(n) + else + xmean(i,j,l) = indefini + end if + end do + end do + end do + + RETURN + END Index: trunk/LMDZ.TITAN.old/Tools/moyzon.F =================================================================== --- trunk/LMDZ.TITAN.old/Tools/moyzon.F (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/moyzon.F (revision 1643) @@ -0,0 +1,48 @@ + SUBROUTINE moyzon(iim,jjp1,nl,indefini,x,xbar) +c======================================================================= +c +c +c Subject: +c ------ +c Calcul de la moyenne zonale de la variable au point scalaire x +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +c Arguments: +c ---------- + + INTEGER iim,jjp1,nl + real indefini + REAL x(iim+1,jjp1,nl) + REAL xbar(jjp1,nl) + +c Local: +c ------ + + iNTEGER i,j,l , n + +c------------------------------------------------------------------------ + do l=1,nl + do j=1,jjp1 + xbar(j,l)=0. + n = 0 + do i=1,iim + if (x(i,j,l).ne.indefini) then + xbar(j,l) = xbar(j,l) + x(i,j,l) + n = n+1 + end if + end do + if (n.ne.0) then + xbar(j,l) = xbar(j,l)/float(n) + else + xbar(j,l) = indefini + end if + end do + end do + + RETURN + END Index: trunk/LMDZ.TITAN.old/Tools/moyzon2.F =================================================================== --- trunk/LMDZ.TITAN.old/Tools/moyzon2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/moyzon2.F (revision 1643) @@ -0,0 +1,50 @@ + SUBROUTINE moyzon2(iim,jjp1,nl,indefini,x,xbar) +c======================================================================= +c +c +c Subject: +c ------ +c Calcul de la moyenne zonale de la variable au point scalaire x +c +c MEME CHOSE QUE moyzon, SAUF LONGUEUR DIM LON DE X +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +c Arguments: +c ---------- + + INTEGER iim,jjp1,nl + real indefini + REAL x(iim,jjp1,nl) + REAL xbar(jjp1,nl) + +c Local: +c ------ + + iNTEGER i,j,l , n + +c------------------------------------------------------------------------ + do l=1,nl + do j=1,jjp1 + xbar(j,l)=0. + n = 0 + do i=1,iim + if (x(i,j,l).ne.indefini) then + xbar(j,l) = xbar(j,l) + x(i,j,l) + n = n+1 + end if + end do + if (n.ne.0) then + xbar(j,l) = xbar(j,l)/float(n) + else + xbar(j,l) = indefini + end if + end do + end do + + RETURN + END Index: trunk/LMDZ.TITAN.old/Tools/planet.h =================================================================== --- trunk/LMDZ.TITAN.old/Tools/planet.h (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/planet.h (revision 1643) @@ -0,0 +1,21 @@ +! Parameters needed to integrate hydrostatic equation: + +real,parameter :: g0=1.35 +!g0: exact mean gravity at radius=2575.km + +real,parameter :: a0=2575.E3 +!a0: 'mean' radius=2575.km + +real,parameter :: R0=296.9 ! molecular gas constant + +real,parameter :: psref=1.4e5 ! reference pressure at surface (Pa) + +real,parameter :: omega=4.5238899E-06 ! angular rotation speed (s-1) + +real,parameter :: localday=1.37889e6 ! local day (s) + +character (len=5),parameter :: planet="Titan" + +real,parameter :: cp0=1039. !doit etre egal a cpp (dyn) et RCPD (phy) +real,parameter :: t0=0. +real,parameter :: nu=0. Index: trunk/LMDZ.TITAN.old/Tools/psi.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/psi.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/psi.F90 (revision 1643) @@ -0,0 +1,341 @@ +program streamfunction + +! SL 12/2009: +! This program reads 4D (lon-lat-alt-time) fields directly from LMD outputs +! without regrid : histmth OR from files recast in log P coordinates (_P) +! +! it computes: +! dmass -- 4D -- mass of each cell +! psi -- 3D -- Stream function +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - surface pressure and surface geopotential +! - meridional winds + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer :: datashape1d ! shape of 1D datasets +integer,dimension(2) :: datashape2d ! shape of 2D datasets +integer,dimension(3) :: datashape3d ! shape of 3D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along altitude (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) +real,dimension(:,:,:,:),allocatable :: za ! areoid levels (m) + +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) +real,dimension(:,:,:,:),allocatable :: vm ! meridional mass flux +real,dimension(:,:,:),allocatable :: psi ! stream function + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +logical :: lmdflag + +real :: deltalat,deltalon ! lat and lon intervals in radians + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) " Program valid for Venus or Titan LMD output files" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading altitude (ie pressure levels)" + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +! Time axis IN PLANET DAYS + +time=time/localday + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_PSI.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) + +text="ps" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitv(lonlength,latlength,altlength,timelength)) + +! meridional wind vitv (in m/s) +text="vitv" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitv ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading meridional wind" + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== + +allocate(za(lonlength,latlength,altlength,timelength)) +! present only in _P regrided files +! For others, using g0*a0*a0/(g0*a0-geop)-a0 + +text="zareoid" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for geop instead... " + text="geop" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get geop ID" +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (za(ilon,ilat,ilev,itim).ne.miss_val) then + za(ilon,ilat,ilev,itim) = (g0*a0*a0/(g0*a0-za(ilon,ilat,ilev,itim))-a0)/1000. ! in km + else + za(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo +enddo +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid/geop" + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== +allocate(rayon(lonlength,latlength,altlength,timelength)) +allocate(grav(lonlength,latlength,altlength,timelength)) +allocate(dmass(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations + if (za(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) + else + rayon(ilon,ilat,ilev,itim) = miss_val + grav(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo +enddo ! timelength + +call cellmass(infid,latlength,lonlength,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +!=============================================================================== +! 2.2.8 Stream function +!=============================================================================== +allocate(vm(lonlength,latlength,altlength,timelength)) +allocate(psi(latlength,altlength,timelength)) + +do itim=1,timelength + +do ilat=1,latlength + do ilev=1,altlength + do ilon=1,lonlength + if (dmass(ilon,ilat,ilev,itim).ne.miss_val) then + vm(ilon,ilat,ilev,itim) = vitv(ilon,ilat,ilev,itim) & + * dmass(ilon,ilat,ilev,itim) & + / (rayon(ilon,ilat,ilev,itim)*deltalat) + else + vm(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo + + +do ilat=1,latlength + psi(ilat,altlength,itim) = 0. + do ilon=1,lonlength + if (vm(ilon,ilat,altlength,itim).ne.miss_val) then + psi(ilat,altlength,itim) = psi(ilat,altlength,itim) & + + vm(ilon,ilat,altlength,itim) + endif + enddo + do ilev=altlength-1,1,-1 + psi(ilat,ilev,itim) = psi(ilat,ilev+1,itim) + do ilon=1,lonlength + if (vm(ilon,ilat,ilev,itim).ne.miss_val) then + psi(ilat,ilev,itim) = psi(ilat,ilev,itim) & + + vm(ilon,ilat,ilev,itim) + endif + enddo + enddo +enddo + +enddo ! timelength + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +! 1D Variables + +datashape1d=time_dimid + +! 3D variables + +datashape3d(1)=lon_dimid +datashape3d(2)=lat_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,lonlength,latlength,timelength,& + "ps ", "Surface pressure ","Pa ",miss_val,& + ps ) + +datashape3d(1)=lat_dimid +datashape3d(2)=alt_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,lonlength,latlength,timelength,& + "psi ", "Stream function ","kg/s ",miss_val,& + psi ) + +! 4D variables + +datashape4d(1)=lon_dimid +datashape4d(2)=lat_dimid +datashape4d(3)=alt_dimid +datashape4d(4)=time_dimid + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "dmass ", "Mass ","kg ",miss_val,& + dmass ) + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'Error, failed to close output file ',outfile +endif + + +end program Index: trunk/LMDZ.TITAN.old/Tools/reverse.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/reverse.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/reverse.F90 (revision 1643) @@ -0,0 +1,132 @@ +subroutine reverse4d(nlon,nlat,np,nt,newf) +!============================================================================== +! Purpose: +! reverse lat, lon and vertical axis on a 3D+time field +!============================================================================== +implicit none +!============================================================================== +! Arguments: +!============================================================================== +integer,intent(in) :: nlon ! longitude size +integer,intent(in) :: nlat ! latitude size +integer,intent(in) :: np ! vertical size +integer,intent(in) :: nt ! time size +real,intent(inout),dimension(nlon,nlat,np,nt) :: newf ! field to be reversed + +!============================================================================== +! Local variables: +!============================================================================== +integer :: i,j,k,l +real,dimension(nlon,nlat,np,nt) :: tmp,tmp2 ! reversed fields +include "planet.h" + +! Vertical axis: + do k=1,np + tmp(:,:,k,:)=newf(:,:,np+1-k,:) + enddo +! horizontal dimensions +if(planet.eq."Venus") then + do l=1,nt + do i=1,nlat + do j=1,nlon + tmp2(j,i,:,l)=tmp(nlon+1-j,nlat+1-i,:,l) + enddo + enddo + enddo +else + tmp2=tmp +endif + +newf=tmp2 + +end subroutine reverse4d + +!=============================================================================== + +subroutine reverse2d(nlon,nlat,newf) +!============================================================================== +! Purpose: +! reverse lat and lon on a 2D field +!============================================================================== +implicit none +!============================================================================== +! Arguments: +!============================================================================== +integer,intent(in) :: nlon ! longitude size +integer,intent(in) :: nlat ! latitude size +real,intent(inout),dimension(nlon,nlat) :: newf ! field to be reversed + +!============================================================================== +! Local variables: +!============================================================================== +integer :: i,j +real,dimension(nlon,nlat) :: tmp ! reversed field + + do i=1,nlat + do j=1,nlon + tmp(j,i)=newf(nlon+1-j,nlat+1-i) + enddo + enddo +newf=tmp + +end subroutine reverse2d + +!=============================================================================== + +subroutine reverse3d(nlon,nlat,nt,newf) +!============================================================================== +! Purpose: +! reverse lat and lon on a 2D+time field +!============================================================================== +implicit none +!============================================================================== +! Arguments: +!============================================================================== +integer,intent(in) :: nlon ! longitude size +integer,intent(in) :: nlat ! latitude size +integer,intent(in) :: nt ! time size +real,intent(inout),dimension(nlon,nlat,nt) :: newf ! field to be reversed + +!============================================================================== +! Local variables: +!============================================================================== +integer :: i,j,l +real,dimension(nlon,nlat,nt) :: tmp ! reversed field + + do l=1,nt + do i=1,nlat + do j=1,nlon + tmp(j,i,l)=newf(nlon+1-j,nlat+1-i,l) + enddo + enddo + enddo +newf=tmp + +end subroutine reverse3d + +!=============================================================================== + +subroutine reverselev(np,newf) +!============================================================================== +! Purpose: +! reverse vertical pressure axis +!============================================================================== +implicit none +!============================================================================== +! Arguments: +!============================================================================== +integer,intent(in) :: np ! vertical size +real,intent(inout),dimension(np) :: newf ! field to be reversed + +!============================================================================== +! Local variables: +!============================================================================== +integer :: k +real,dimension(np) :: tmp ! reversed field + + do k=1,np + tmp(k)=newf(np+1-k) + enddo +newf=tmp + +end subroutine reverselev Index: trunk/LMDZ.TITAN.old/Tools/stability.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/stability.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/stability.F90 (revision 1643) @@ -0,0 +1,462 @@ +program stability + +! SL 12/2009: +! This program reads 4D (lon-lat-alt-time) fields recast in log P coordinates +! +! it computes: +! stab -- 4D -- stability +! Ri -- 4D -- Richardson number +! deqc -- 3D -- distance to cyclostrophic equilibrium +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - surface pressure and surface geopotential +! - atmospheric temperature +! - zonal and meridional winds +! - altitude above areoid + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer,dimension(3) :: datashape3d ! shape of 3D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along altitude (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:,:),allocatable :: temp ! atmospheric temperature +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) +real,dimension(:,:,:,:),allocatable :: za ! above areoid levels (m) + +!!! output variables +real,dimension(:,:,:,:),allocatable :: stab ! stability (K/km) +real,dimension(:,:,:,:),allocatable :: Ri ! Richardson number +real,dimension(:,:,:),allocatable :: deqc ! distance to cyclostrophic equilibrium + +! variables prepared for computation (4D) +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) + +! variables prepared for computation inside timeloop +real,dimension(:,:,:),allocatable :: t3d ! temp +real,dimension(:,:,:),allocatable :: u3d ! zonal wind +real,dimension(:,:,:),allocatable :: v3d ! merid wind +! variables obtained from computation inside timeloop +real,dimension(:,:,:),allocatable :: stab3d ! stability (K/km) +real,dimension(:,:,:),allocatable :: Ri3d ! Richardson number +real,dimension(:,:),allocatable :: deqc2d ! distance to cyclostrophic equilibrium + +real,dimension(:,:),allocatable :: t2d ! temp +real,dimension(:,:),allocatable :: u2d ! zonal wind +real,dimension(:,:),allocatable :: v2d ! merid wind +real,dimension(:,:),allocatable :: dtsdp ! d(temp)/d(plev) +real,dimension(:,:),allocatable :: dusdp ! du/d(plev) +real,dimension(:,:),allocatable :: dvsdp ! dv/d(plev) + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +logical :: lmdflag + +real :: deltalat,deltalon ! lat and lon intervals in radians +real :: fac1,ecden,ecnum ! for cyclo eq. + +real :: cpdet + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) "Program valid for files with pressure axis (*_P.nc)" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading altitude (ie pressure levels)" + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_STA.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) + +text="ps" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" + +!=============================================================================== +! 2.1.2 Atmospheric temperature +!=============================================================================== +allocate(temp(lonlength,latlength,altlength,timelength)) + +text="temp" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for t instead... " + text="t" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get temperature ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading temperature" + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitu(lonlength,latlength,altlength,timelength)) +allocate(vitv(lonlength,latlength,altlength,timelength)) + +! zonal wind vitu (in m/s) +text="vitu" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitu ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zonal wind" + +! meridional wind vitv (in m/s) +text="vitv" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitv ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading meridional wind" + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== +! Only needed if g(z) on Titan... + +! allocate(za(lonlength,latlength,altlength,timelength)) + +! text="zareoid" +! call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +! if (ierr1.ne.NF_NOERR) stop "Error: Failed to get za ID" +! if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid" + +!=============================================================================== +!!! Allocations before timeloop +!=============================================================================== + +! latlength correspond a jjm+1 +! mais lonlength correspond a iim +! pour boucler en longitude, on a besoin du point iim+1 (= 1) + +allocate(rayon(lonlength+1,latlength,altlength,timelength)) +allocate(grav(lonlength+1,latlength,altlength,timelength)) +allocate(dmass(lonlength+1,latlength,altlength,timelength)) + +allocate(t3d(lonlength+1,latlength,altlength)) +allocate(u3d(lonlength+1,latlength,altlength)) +allocate(v3d(lonlength+1,latlength,altlength)) + +allocate(t2d(latlength,altlength)) +allocate(u2d(latlength,altlength)) +allocate(v2d(latlength,altlength)) +allocate(dtsdp(latlength,altlength)) +allocate(dusdp(latlength,altlength)) +allocate(dvsdp(latlength,altlength)) + +allocate(stab(lonlength,latlength,altlength,timelength)) +allocate(Ri(lonlength,latlength,altlength,timelength)) +allocate(deqc(latlength,altlength,timelength)) + +allocate(stab3d(lonlength+1,latlength,altlength)) +allocate(Ri3d(lonlength+1,latlength,altlength)) +allocate(deqc2d(latlength,altlength)) + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations +! if (za(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) +! else +! rayon(ilon,ilat,ilev,itim) = miss_val +! grav(ilon,ilat,ilev,itim) = miss_val +! endif + enddo + enddo +enddo +enddo ! timelength + +rayon(lonlength+1,:,:,:) = rayon(1,:,:,:) + grav(lonlength+1,:,:,:) = grav(1,:,:,:) + +call cellmass(infid,latlength,lonlength+1,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +!=============================================================================== +!!! GLOBAL TIME LOOP !!! +!=============================================================================== +do itim=1,timelength + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.3 Init of 3D variables +!=============================================================================== + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + t3d(ilon,ilat,ilev) = temp(ilon,ilat,ilev,itim) + u3d(ilon,ilat,ilev) = vitu(ilon,ilat,ilev,itim) + v3d(ilon,ilat,ilev) = vitv(ilon,ilat,ilev,itim) + enddo + enddo +enddo + + t3d(lonlength+1,:,:) = t3d(1,:,:) + u3d(lonlength+1,:,:) = u3d(1,:,:) + v3d(lonlength+1,:,:) = v3d(1,:,:) + +!=============================================================================== +! 2.2.4 Stability +!=============================================================================== + +do ilon=1,lonlength+1 + t2d(:,:) = t3d(ilon,:,:) + call dx_dp(latlength,altlength,miss_val,plev,t2d,dtsdp) + do ilat=1,latlength + do ilev=1,altlength + if ((grav(ilon,ilat,ilev,itim).ne.miss_val).and. & + ( t3d(ilon,ilat,ilev).ne.miss_val) ) then + stab3d(ilon,ilat,ilev) = grav(ilon,ilat,ilev,itim)* & + ( 1./cpdet(t2d(ilat,ilev)) & + - plev(ilev)*dtsdp(ilat,ilev)/(R0*t2d(ilat,ilev)) ) + stab3d(ilon,ilat,ilev) = stab3d(ilon,ilat,ilev)*1000. ! passage en K/km + else + stab3d(ilon,ilat,ilev) = miss_val + endif + enddo + enddo +enddo + +!=============================================================================== +! 2.2.5 Richardson number +!=============================================================================== + +do ilon=1,lonlength+1 + u2d(:,:) = u3d(ilon,:,:) + v2d(:,:) = v3d(ilon,:,:) + call dx_dp(latlength,altlength,miss_val,plev,u2d,dusdp) + call dx_dp(latlength,altlength,miss_val,plev,v2d,dvsdp) + do ilat=1,latlength + do ilev=1,altlength + if ((grav(ilon,ilat,ilev,itim).ne.miss_val).and. & + ( u3d(ilon,ilat,ilev).ne.miss_val).and. & + ( v3d(ilon,ilat,ilev).ne.miss_val).and. & + ( t3d(ilon,ilat,ilev).ne.miss_val) ) then + Ri3d(ilon,ilat,ilev) = & ! attention, transfo a cause de du/dp au lieu de du/dz + stab3d(ilon,ilat,ilev)*t3d(ilon,ilat,ilev)*R0*R0 & + / (grav(ilon,ilat,ilev,itim)*plev(ilev)*plev(ilev)) & + / (dusdp(ilat,ilev)*dusdp(ilat,ilev)+dvsdp(ilat,ilev)*dvsdp(ilat,ilev)) + else + Ri3d(ilon,ilat,ilev) = miss_val + endif + enddo + enddo +enddo + +!=============================================================================== +! 2.2.6 Distance to cyclostrophic equilibrium +!=============================================================================== + +call moyzon(lonlength,latlength,altlength,miss_val,u3d,u2d) +call moyzon(lonlength,latlength,altlength,miss_val,t3d,t2d) +call dx_dp(latlength,altlength,miss_val,plev,u2d,dusdp) + +do ilat=2,latlength-1 + if (tan(lat(ilat)*pi/180.).ne.0.) then + fac1 = R0/tan(lat(ilat)*pi/180.) + else + fac1 = miss_val + endif + do ilev=1,altlength + if ((dusdp(ilat,ilev).ne.miss_val).and. & + ( u2d(ilat,ilev).ne.miss_val).and. & + ( fac1.ne.miss_val).and. & + ( t2d(ilat,ilev).ne.miss_val) ) then + ecden = dusdp(ilat,ilev)*(2.*u2d(ilat,ilev)*plev(ilev)) + ecnum = ((t2d(ilat+1,ilev)-t2d(ilat-1,ilev))/(2.*deltalat)*fac1-ecden)*100. + deqc2d(ilat,ilev) = ecnum/ecden + else + deqc2d(ilat,ilev) = miss_val + endif + enddo +enddo +do ilev=1,altlength + deqc2d(1,ilev) = miss_val + deqc2d(latlength,ilev) = miss_val +enddo + +!=============================================================================== +! 2.2.7 Building 3D+time variables +!=============================================================================== + + deqc(:,:,itim) = deqc2d(:,:) + stab(:,:,:,itim) = stab3d(1:lonlength,:,:) + Ri(:,:,:,itim) = Ri3d(1:lonlength,:,:) + + +enddo ! timelength +!=============================================================================== +!!! END GLOBAL TIME LOOP !!! +!=============================================================================== + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +! 3D Variables + +datashape3d(1)=lat_dimid +datashape3d(2)=alt_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "deqc ", "Distance to cyclo eq","per cent ",miss_val,& + deqc ) + +! 4D Variables + +datashape4d(1)=lon_dimid +datashape4d(2)=lat_dimid +datashape4d(3)=alt_dimid +datashape4d(4)=time_dimid + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "stab ", "Stability ","K/km ",miss_val,& + stab ) + +call write_var4d(outfid,datashape4d,lonlength,latlength,altlength,timelength,& + "Ri ", "Richardson number "," ",miss_val,& + Ri ) + + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'Error, failed to close output file ',outfile +endif + + +end program Index: trunk/LMDZ.TITAN.old/Tools/tem.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/tem.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/tem.F90 (revision 1643) @@ -0,0 +1,503 @@ +program tem + +! SL 01/2010: +! This program reads 4D (lon-lat-alt-time) fields recast in log P coordinates +! Developed from the tool built by Audrey Crespin during her PhD. +! +! it computes TransEulerianMean variables: +! +! vtem -- 3D -- Residual meridional speed (m s-1) +! wtem -- 3D -- Residual vertical speed (Pa s-1) +! psitem -- 3D -- Residual stream function (kg s-1) +! epfy -- 3D -- meridional component of Eliassen-Palm flux +! epfz -- 3D -- vertical component of Eliassen-Palm flux +! divepf -- 3D -- Divergence of Eliassen-Palm flux +! ammctem - 3D -- Acc due to residual MMC +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - pressure vertical coordinate +! - surface pressure +! - atmospheric temperature +! - zonal, meridional and vertical (Pa/s) winds +! - altitude above areoid + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer,dimension(3) :: datashape3d ! shape of 3D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along altitude (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:,:),allocatable :: temp ! atmospheric temperature +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitw ! vertical wind (in Pa/s, then converted in m/s) +real,dimension(:,:,:,:),allocatable :: za ! above areoid levels (m) + +!!! output variables +real,dimension(:,:,:),allocatable :: epy ! merid component of EP flux +real,dimension(:,:,:),allocatable :: epz ! verti component of EP flux +real,dimension(:,:,:),allocatable :: divep ! divergence of EP flux +real,dimension(:,:,:),allocatable :: ammctem ! acc by residual mmc +real,dimension(:,:,:),allocatable :: uzon ! mean zonal wind +real,dimension(:,:,:),allocatable :: vtem ! residual merid wind +real,dimension(:,:,:),allocatable :: wtem ! residual verti wind +real,dimension(:,:,:),allocatable :: psitem ! residual stream function + +! variables prepared for computation (4D) +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) + +! variables prepared for computation inside timeloop +real,dimension(:,:,:),allocatable :: r3d ! distance to center (m) +real,dimension(:,:,:),allocatable :: rsurg ! rayon/grav +real,dimension(:,:,:),allocatable :: t3d ! temp +real,dimension(:,:,:),allocatable :: u3d ! zonal wind +real,dimension(:,:,:),allocatable :: v3d ! merid wind +real,dimension(:,:,:),allocatable :: w3d ! verti wind +real,dimension(:,:,:),allocatable :: pk3d ! Exner function +real,dimension(:,:,:),allocatable :: teta ! potential temp +! variables obtained from computation inside timeloop +real,dimension(:,:),allocatable :: epy2d ! merid component of EP flux +real,dimension(:,:),allocatable :: epz2d ! verti component of EP flux +real,dimension(:,:),allocatable :: div2d ! divergence of EP flux +real,dimension(:,:),allocatable :: ammc2d ! acc by residual mmc +real,dimension(:,:),allocatable :: ubar ! mean zonal wind +real,dimension(:,:),allocatable :: vtem2d ! residual merid wind +real,dimension(:,:),allocatable :: wtem2d ! residual verti wind + +real,dimension(:,:),allocatable :: rbar ! distance to center (zonal ave) +real,dimension(:,:),allocatable :: rsurgbar ! rayon/grav +real,dimension(:,:),allocatable :: vm ! merid mass flux (zonal ave) +real,dimension(:,:),allocatable :: psi ! residual stream function +real :: deltalat,deltalon ! lat and lon intervals in radians +real,dimension(:,:,:),allocatable :: deltap ! pressure thickness of each layer (Pa) + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +logical :: lmdflag + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) "Program valid for files with pressure axis (*_P.nc)" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading altitude (ie pressure levels)" + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_TEM.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) + +text="ps" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" + +!=============================================================================== +! 2.1.2 Atmospheric temperature +!=============================================================================== +allocate(temp(lonlength,latlength,altlength,timelength)) + +text="temp" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for t instead... " + text="t" + call get_var4d(infid,lonlength,latlength,altlength,timelength,text,temp,miss_val,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get temperature ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading temperature" + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitu(lonlength,latlength,altlength,timelength)) +allocate(vitv(lonlength,latlength,altlength,timelength)) +allocate(vitw(lonlength,latlength,altlength,timelength)) + +! zonal wind vitu (in m/s) +text="vitu" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitu ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zonal wind" + +! meridional wind vitv (in m/s) +text="vitv" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitv ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading meridional wind" + +! vertical wind vitw (in Pa/s) +text="vitw" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitw,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitw ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading vertical wind" + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== +! Only needed if g(z) on Titan... + +! allocate(za(lonlength,latlength,altlength,timelength)) + +! text="zareoid" +! call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +! if (ierr1.ne.NF_NOERR) stop "Error: Failed to get za ID" +! if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid" + +!=============================================================================== +!!! Allocations before timeloop +!=============================================================================== + +! latlength correspond a jjm+1 +! mais lonlength correspond a iim +! pour boucler en longitude, on a besoin du point iim+1 (= 1) + +allocate(rayon(lonlength+1,latlength,altlength,timelength)) +allocate(grav(lonlength+1,latlength,altlength,timelength)) +allocate(dmass(lonlength+1,latlength,altlength,timelength)) + +allocate(r3d(lonlength+1,latlength,altlength)) +allocate(rsurg(lonlength+1,latlength,altlength)) +allocate(rbar(latlength,altlength)) +allocate(rsurgbar(latlength,altlength)) + +allocate(t3d(lonlength+1,latlength,altlength)) +allocate(u3d(lonlength+1,latlength,altlength)) +allocate(v3d(lonlength+1,latlength,altlength)) +allocate(w3d(lonlength+1,latlength,altlength)) +allocate(pk3d(lonlength+1,latlength,altlength)) +allocate(teta(lonlength+1,latlength,altlength)) + +allocate(epy(latlength,altlength,timelength)) +allocate(epz(latlength,altlength,timelength)) +allocate(divep(latlength,altlength,timelength)) +allocate(ammctem(latlength,altlength,timelength)) +allocate(uzon(latlength,altlength,timelength)) +allocate(vtem(latlength,altlength,timelength)) +allocate(wtem(latlength,altlength,timelength)) + +allocate(epy2d(latlength,altlength)) +allocate(epz2d(latlength,altlength)) +allocate(div2d(latlength,altlength)) +allocate(ammc2d(latlength,altlength)) +allocate(ubar(latlength,altlength)) +allocate(vtem2d(latlength,altlength)) +allocate(wtem2d(latlength,altlength)) + +allocate(vm(latlength,altlength)) +allocate(psi(latlength,altlength)) +allocate(psitem(latlength,altlength,timelength)) + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations +! if (za(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) +! else +! rayon(ilon,ilat,ilev,itim) = miss_val +! grav(ilon,ilat,ilev,itim) = miss_val +! endif + enddo + enddo +enddo +enddo ! timelength + +rayon(lonlength+1,:,:,:) = rayon(1,:,:,:) + grav(lonlength+1,:,:,:) = grav(1,:,:,:) + +call cellmass(infid,latlength,lonlength+1,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +!=============================================================================== +!!! GLOBAL TIME LOOP !!! +!=============================================================================== +do itim=1,timelength + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.3 Init of 3D variables +!=============================================================================== + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + r3d(ilon,ilat,ilev) = rayon(ilon,ilat,ilev,itim) + t3d(ilon,ilat,ilev) = temp(ilon,ilat,ilev,itim) + u3d(ilon,ilat,ilev) = vitu(ilon,ilat,ilev,itim) + v3d(ilon,ilat,ilev) = vitv(ilon,ilat,ilev,itim) + w3d(ilon,ilat,ilev) = vitw(ilon,ilat,ilev,itim) + pk3d(ilon,ilat,ilev) = cp0*(plev(ilev)/psref)**(R0/cp0) + enddo + enddo +enddo + + t3d(lonlength+1,:,:) = t3d(1,:,:) + u3d(lonlength+1,:,:) = u3d(1,:,:) + v3d(lonlength+1,:,:) = v3d(1,:,:) + w3d(lonlength+1,:,:) = w3d(1,:,:) +pk3d(lonlength+1,:,:) = pk3d(1,:,:) + +call t2tpot((lonlength+1)*latlength*altlength,t3d,teta,pk3d) + +!=============================================================================== +! 2.2.4 TEM and Eliassen-Palm +!=============================================================================== + +print*,"eliasflu_meridien",itim + +call moyzon(lonlength,latlength,altlength,miss_val,r3d,rbar) +call moyzon(lonlength,latlength,altlength,miss_val,u3d,ubar) + +call epflux(lonlength+1,latlength,altlength,miss_val,lat,rbar & + ,teta,u3d,v3d,w3d,plev & + ,epy2d,epz2d,div2d,vtem2d,wtem2d,ammc2d & +! ,vpupbar2d,wpupbar2d,vpvpbar2d,wpvpbar2d & +! ,vptetapbar2d,wptetapbar2d & + ) + +!=============================================================================== +! 2.2.5 Stream function +!=============================================================================== + +do ilon=1,lonlength+1 + do ilat=1,latlength + do ilev=1,altlength + if (dmass(ilon,ilat,ilev,itim).ne.miss_val) then +! rsurg: r*dp/g = dm/(r cos(lat) dlon dlat) !!! + rsurg(ilon,ilat,ilev) = dmass(ilon,ilat,ilev,itim) & + / (r3d(ilon,ilat,ilev)*coslat(ilat)*deltalon*deltalat) + else + rsurg(ilon,ilat,ilev) = miss_val + endif + enddo + enddo +enddo + +call moyzon(lonlength,latlength,altlength,miss_val,rsurg,rsurgbar) + +do ilat=1,latlength + do ilev=1,altlength + if ( (vtem2d(ilat,ilev).ne.miss_val).and. & + (rsurgbar(ilat,ilev).ne.miss_val) ) then + vm(ilat,ilev) = vtem2d(ilat,ilev) & + * 2.*pi*rsurgbar(ilat,ilev)*coslat(ilat) + else + vm(ilat,ilev) = miss_val + endif + enddo +enddo + + +do ilat=1,latlength + psi(ilat,altlength) = 0. + if (vm(ilat,altlength).ne.miss_val) then + psi(ilat,altlength) = psi(ilat,altlength) & + + vm(ilat,altlength) + endif + do ilev=altlength-1,1,-1 + psi(ilat,ilev) = psi(ilat,ilev+1) + if (vm(ilat,ilev).ne.miss_val) then + psi(ilat,ilev) = psi(ilat,ilev) & + + vm(ilat,ilev) + endif + enddo +enddo + +!=============================================================================== +! 2.2.6 Building 2D+time variables +!=============================================================================== + + epy(:,:,itim) = epy2d(:,:) + epz(:,:,itim) = epz2d(:,:) + divep(:,:,itim) = div2d(:,:) +ammctem(:,:,itim) = ammc2d(:,:) + uzon(:,:,itim) = ubar(:,:) + vtem(:,:,itim) = vtem2d(:,:) + wtem(:,:,itim) = wtem2d(:,:) + psitem(:,:,itim) = psi(:,:) + + +enddo ! timelength +!=============================================================================== +!!! END GLOBAL TIME LOOP !!! +!=============================================================================== + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +datashape3d(1)=lat_dimid +datashape3d(2)=alt_dimid +datashape3d(3)=time_dimid + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "epy ", "EP flux on lat ","m3 s-2 ",miss_val,& + epy ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "epz ", "EP flux on press ","m3 s-2 ",miss_val,& + epz ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "divep ", "Div of EP flux ","m s-2 ",miss_val,& + divep ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "ammctem ", "acc by residual mmc ","m s-2 ",miss_val,& + ammctem ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "uzon ", "Mean zonal wind ","m s-1 ",miss_val,& + uzon ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "vtem ", "Resid TEM merid wind","m s-1 ",miss_val,& + vtem ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "wtem ", "Resid TEM verti wind","Pa s-1 ",miss_val,& + wtem ) + +call write_var3d(outfid,datashape3d,latlength,altlength,timelength,& + "psitem ", "Resid stream funct ","kg s-1 ",miss_val,& + psitem ) + + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile + + +end program Index: trunk/LMDZ.TITAN.old/Tools/titan.h =================================================================== --- trunk/LMDZ.TITAN.old/Tools/titan.h (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/titan.h (revision 1643) @@ -0,0 +1,21 @@ +! Parameters needed to integrate hydrostatic equation: + +real,parameter :: g0=1.35 +!g0: exact mean gravity at radius=2575.km + +real,parameter :: a0=2575.E3 +!a0: 'mean' radius=2575.km + +real,parameter :: R0=296.9 ! molecular gas constant + +real,parameter :: psref=1.4e5 ! reference pressure at surface (Pa) + +real,parameter :: omega=4.5238899E-06 ! angular rotation speed (s-1) + +real,parameter :: localday=1.37889e6 ! local day (s) + +character (len=5),parameter :: planet="Titan" + +real,parameter :: cp0=1039. !doit etre egal a cpp (dyn) et RCPD (phy) +real,parameter :: t0=0. +real,parameter :: nu=0. Index: trunk/LMDZ.TITAN.old/Tools/tmc.F90 =================================================================== --- trunk/LMDZ.TITAN.old/Tools/tmc.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/tmc.F90 (revision 1643) @@ -0,0 +1,628 @@ +program tmc + +! SL 01/2010: +! This program reads 4D (lon-lat-alt-time) fields recast in log P coordinates +! +! it computes angular momentum transport from high-frequency outputs: +! +! totvang -- 2D -- Meridional transport of angular momentum, total (m3 s-2) +! totwang -- 2D -- Vertical transport of angular momentum, total (m3 s-2) +! mmcvang -- 2D -- Meridional transport of angular momentum, by MMC (m3 s-2) +! mmcwang -- 2D -- Vertical transport of angular momentum, by MMC (m3 s-2) +! trsvang -- 2D -- Meridional transport of angular momentum, transients (m3 s-2) +! trswang -- 2D -- Vertical transport of angular momentum, transients (m3 s-2) +! stnvang -- 2D -- Meridional transport of angular momentum, stationaries (m3 s-2) +! stnwang -- 2D -- Vertical transport of angular momentum, stationaries (m3 s-2) +! dmass -- 2D -- Mass in each cell (dmassmeanbar) +! +! Minimal requirements and dependencies: +! The dataset must include the following data: +! - pressure vertical coordinate +! - surface pressure +! - zonal, meridional and vertical (Pa/s) winds +! - altitude above areoid +! +! Convention: qbar <=> zonal average / qstar = q - qbar +! qmean <=> temporal average / qprim = q - qmean +! +! Therefore: ((qv)mean)bar (total) +! = qmeanbar * vmeanbar (mmc) +! + (qstarmean * vstarmean)bar (stn) +! + (qprim * vprim)meanbar (trs) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +implicit none + +include "netcdf.inc" ! NetCDF definitions + +character (len=128) :: infile ! input file name (name_P.nc) +character (len=128) :: outfile ! output file name + +character (len=64) :: text ! to store some text +integer infid ! NetCDF input file ID +integer outfid ! NetCDF output file ID +integer lon_dimid,lat_dimid,alt_dimid,time_dimid ! NetCDF dimension IDs +integer lon_varid,lat_varid,alt_varid,time_varid +integer,dimension(2) :: datashape2d ! shape of 3D datasets +integer,dimension(3) :: datashape3d ! shape of 3D datasets +integer,dimension(4) :: datashape4d ! shape of 4D datasets + +real :: miss_val ! special "missing value" to specify missing data +real,parameter :: miss_val_def=-9.99e+33 ! default value for "missing value" +real :: pi +real,dimension(:),allocatable :: lon ! longitude +integer lonlength ! # of grid points along longitude +real,dimension(:),allocatable :: lat ! latitude +real,dimension(:),allocatable :: coslat ! cos of latitude +integer latlength ! # of grid points along latitude +real,dimension(:),allocatable :: plev ! Pressure levels (Pa) +integer altlength ! # of grid point along altitude (of input datasets) +real,dimension(:),allocatable :: time ! time +integer timelength ! # of points along time +real,dimension(:,:,:),allocatable :: ps ! surface pressure +real,dimension(:,:,:,:),allocatable :: vitu ! zonal wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitv ! meridional wind (in m/s) +real,dimension(:,:,:,:),allocatable :: vitw ! vertical wind (in Pa/s, then converted in m/s) +real,dimension(:,:,:,:),allocatable :: za ! above areoid levels (m) + +!!! output variables +real,dimension(:,:),allocatable :: totvang ! merid transport of ang momentum +real,dimension(:,:),allocatable :: totwang ! verti transport of ang momentum +real,dimension(:,:),allocatable :: mmcvang ! merid transport of ang momentum +real,dimension(:,:),allocatable :: mmcwang ! verti transport of ang momentum +real,dimension(:,:),allocatable :: trsvang ! merid transport of ang momentum +real,dimension(:,:),allocatable :: trswang ! verti transport of ang momentum +real,dimension(:,:),allocatable :: stnvang ! merid transport of ang momentum +real,dimension(:,:),allocatable :: stnwang ! verti transport of ang momentum +real,dimension(:,:),allocatable :: dmassmeanbar + +! local variables +real :: deltalat,deltalon ! lat and lon intervals in radians +real,dimension(:,:,:,:),allocatable :: rayon ! distance to center (m) +real,dimension(:,:,:,:),allocatable :: grav ! gravity field (m s-2) +real,dimension(:,:,:,:),allocatable :: dmass ! mass in cell (kg) +real,dimension(:,:,:),allocatable :: dmassmean + +real,dimension(:,:,:,:),allocatable :: osam ! planetary rotation specific ang (m2/s) +real,dimension(:,:,:,:),allocatable :: rsam ! zonal wind specific ang (m2/s) +real,dimension(:,:,:,:),allocatable :: tsam ! total specific ang (m2/s) + +real,dimension(:,:,:,:),allocatable :: vang ! v * specific ang (m3/s) +real,dimension(:,:,:,:),allocatable :: wang ! w * specific ang (m3/s) +real,dimension(:,:,:,:),allocatable :: vstar +real,dimension(:,:,:,:),allocatable :: wstar +real,dimension(:,:,:,:),allocatable :: angstar +real,dimension(:,:,:,:),allocatable :: vprim +real,dimension(:,:,:,:),allocatable :: wprim +real,dimension(:,:,:,:),allocatable :: angprim +real,dimension(:,:,:,:),allocatable :: angprimvprim +real,dimension(:,:,:,:),allocatable :: angprimwprim + +! lon,lat,alt +real,dimension(:,:,:),allocatable :: vangmean +real,dimension(:,:,:),allocatable :: wangmean +real,dimension(:,:,:),allocatable :: vmean +real,dimension(:,:,:),allocatable :: wmean +real,dimension(:,:,:),allocatable :: angmean +real,dimension(:,:,:),allocatable :: angprimvprimmean +real,dimension(:,:,:),allocatable :: angprimwprimmean +real,dimension(:,:,:),allocatable :: vstarmean +real,dimension(:,:,:),allocatable :: wstarmean +real,dimension(:,:,:),allocatable :: angstarmean +real,dimension(:,:,:),allocatable :: angstarmeanvstarmean +real,dimension(:,:,:),allocatable :: angstarmeanwstarmean +real,dimension(:,:,:),allocatable :: v3d ! intermediate for vbar +real,dimension(:,:,:),allocatable :: w3d ! intermediate for wbar +real,dimension(:,:,:),allocatable :: ang3d ! intermediate for angbar + +! lat,alt,time +real,dimension(:,:,:),allocatable :: vbar +real,dimension(:,:,:),allocatable :: wbar +real,dimension(:,:,:),allocatable :: angbar + +!lat,alt +real,dimension(:,:),allocatable :: vmeanbar +real,dimension(:,:),allocatable :: wmeanbar +real,dimension(:,:),allocatable :: angmeanbar +real,dimension(:,:),allocatable :: vbar2d ! intermediate for vbar +real,dimension(:,:),allocatable :: wbar2d ! intermediate for wbar +real,dimension(:,:),allocatable :: angbar2d ! intermediate for qbar + +integer ierr,ierr1,ierr2 ! NetCDF routines return codes +integer i,j,ilon,ilat,ilev,itim ! for loops +logical :: lmdflag + +include "planet.h" + +!=============================================================================== +! 1. Input parameters +!=============================================================================== + +pi = 2.*asin(1.) +miss_val = miss_val_def + +write(*,*) "" +write(*,*) "You are working on the atmosphere of ",planet + +!=============================================================================== +! 1.1 Input file +!=============================================================================== + +write(*,*) "" +write(*,*) "Program valid for files with pressure axis (*_P.nc)" +write(*,*) "Enter input file name:" + +read(*,'(a128)') infile +write(*,*) "" + +! open input file + +ierr = NF_OPEN(infile,NF_NOWRITE,infid) +if (ierr.ne.NF_NOERR) then + write(*,*) 'ERROR: Pb opening file ',trim(infile) + stop "" +endif + +!=============================================================================== +! 1.2 Get grids in lon,lat,alt(pressure),time +!=============================================================================== + +call get_iddim(infid,lat_varid,latlength,lon_varid,lonlength,& + alt_varid,altlength,time_varid,timelength,lmdflag ) + +allocate(lon(lonlength)) +ierr=NF_GET_VAR_REAL(infid,lon_varid,lon) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading longitude" + +allocate(lat(latlength)) +ierr=NF_GET_VAR_REAL(infid,lat_varid,lat) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading lat" + +allocate(coslat(latlength)) +! Beware of rounding problems at poles... +coslat(:) = max(0.,cos(lat(:)*pi/180.)) + +! Lat, lon pressure intervals +deltalat = abs(lat(2)-lat(1))*pi/180. +deltalon = abs(lon(2)-lon(1))*pi/180. + +allocate(plev(altlength)) +ierr=NF_GET_VAR_REAL(infid,alt_varid,plev) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading altitude (ie pressure levels)" + +allocate(time(timelength)) +ierr=NF_GET_VAR_REAL(infid,time_varid,time) +if (ierr.ne.NF_NOERR) stop "Error: Failed reading time" + +!=============================================================================== +! 1.3 Get output file name +!=============================================================================== +write(*,*) "" +!write(*,*) "Enter output file name" +!read(*,*) outfile +outfile=infile(1:len_trim(infile)-3)//"_TMC.nc" +write(*,*) "Output file name is: "//trim(outfile) + + + +!=============================================================================== +! 2.1 Store needed fields +!=============================================================================== + +!=============================================================================== +! 2.1.1 Surface pressure +!=============================================================================== +allocate(ps(lonlength,latlength,timelength)) + +text="ps" +call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) then + write(*,*) " looking for psol instead... " + text="psol" + call get_var3d(infid,lonlength,latlength,timelength,text,ps,ierr1,ierr2) + if (ierr1.ne.NF_NOERR) stop "Error: Failed to get psol ID" +endif +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading surface pressure" + +!=============================================================================== +! 2.1.3 Winds +!=============================================================================== +allocate(vitu(lonlength,latlength,altlength,timelength)) +allocate(vitv(lonlength,latlength,altlength,timelength)) +allocate(vitw(lonlength,latlength,altlength,timelength)) + +! zonal wind vitu (in m/s) +text="vitu" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitu,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitu ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zonal wind" + +! meridional wind vitv (in m/s) +text="vitv" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitv,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitv ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading meridional wind" + +! vertical wind vitw (in Pa/s) +text="vitw" +call get_var4d(infid,lonlength,latlength,altlength,timelength,text,vitw,miss_val,ierr1,ierr2) +if (ierr1.ne.NF_NOERR) stop "Error: Failed to get vitw ID" +if (ierr2.ne.NF_NOERR) stop "Error: Failed reading vertical wind" + +!=============================================================================== +! 2.1.4 Altitude above areoide +!=============================================================================== +! Only needed if g(z) on Titan... + +! allocate(za(lonlength,latlength,altlength,timelength)) + +! text="zareoid" +! call get_var4d(infid,lonlength,latlength,altlength,timelength,text,za,miss_val,ierr1,ierr2) +! if (ierr1.ne.NF_NOERR) stop "Error: Failed to get za ID" +! if (ierr2.ne.NF_NOERR) stop "Error: Failed reading zareoid" + +!=============================================================================== +! 2.2 Computations +!=============================================================================== + +!=============================================================================== +! 2.2.2 Mass in cells +!=============================================================================== +allocate(rayon(lonlength,latlength,altlength,timelength)) +allocate( grav(lonlength,latlength,altlength,timelength)) +allocate(dmass(lonlength,latlength,altlength,timelength)) +allocate(dmassmean(lonlength,latlength,altlength)) +allocate(dmassmeanbar(latlength,altlength)) + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength +! Need to be consistent with GCM computations + if (vitu(ilon,ilat,ilev,itim).ne.miss_val) then + rayon(ilon,ilat,ilev,itim) = a0 +! rayon(ilon,ilat,ilev,itim) = za(ilon,ilat,ilev,itim) + a0 + grav(ilon,ilat,ilev,itim) = g0*a0*a0 & + /(rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim)) + else + rayon(ilon,ilat,ilev,itim) = miss_val + grav(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo +enddo ! timelength + +call cellmass(infid,latlength,lonlength,altlength,timelength,lmdflag, & + miss_val,deltalon,deltalat,coslat,plev,ps,grav,rayon, & + dmass ) + +call moytim(lonlength,latlength,altlength,timelength,miss_val,dmass,dmassmean) +call moyzon2(lonlength,latlength,altlength,miss_val,dmassmean,dmassmeanbar) + +print*,"OK dmass" + +!=============================================================================== +! 2.2.3 Specific angular momentum +!=============================================================================== +allocate(osam(lonlength,latlength,altlength,timelength)) +allocate(rsam(lonlength,latlength,altlength,timelength)) +allocate(tsam(lonlength,latlength,altlength,timelength)) + +do itim=1,timelength +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if (rayon(ilon,ilat,ilev,itim).ne.miss_val) then + osam(ilon,ilat,ilev,itim) = & + rayon(ilon,ilat,ilev,itim)*rayon(ilon,ilat,ilev,itim) & + * coslat(ilat)*coslat(ilat) & + * omega + rsam(ilon,ilat,ilev,itim) = vitu(ilon,ilat,ilev,itim) & + * rayon(ilon,ilat,ilev,itim)*coslat(ilat) + tsam(ilon,ilat,ilev,itim) = osam(ilon,ilat,ilev,itim)& + + rsam(ilon,ilat,ilev,itim) + else + osam(ilon,ilat,ilev,itim) = miss_val + rsam(ilon,ilat,ilev,itim) = miss_val + tsam(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo +enddo +enddo ! timelength + +print*,"debut tprt ang" + +!=============================================================================== +! 2.2.4 Angular momentum transport +!=============================================================================== +! allocations +!------------- +allocate(vang(lonlength,latlength,altlength,timelength)) +allocate(wang(lonlength,latlength,altlength,timelength)) +allocate( vstar(lonlength,latlength,altlength,timelength)) +allocate( wstar(lonlength,latlength,altlength,timelength)) +allocate(angstar(lonlength,latlength,altlength,timelength)) +allocate( vprim(lonlength,latlength,altlength,timelength)) +allocate( wprim(lonlength,latlength,altlength,timelength)) +allocate(angprim(lonlength,latlength,altlength,timelength)) +allocate(angprimvprim(lonlength,latlength,altlength,timelength)) +allocate(angprimwprim(lonlength,latlength,altlength,timelength)) + +! lon,lat,alt +allocate(vangmean(lonlength,latlength,altlength)) +allocate(wangmean(lonlength,latlength,altlength)) +allocate( vmean(lonlength,latlength,altlength)) +allocate( wmean(lonlength,latlength,altlength)) +allocate(angmean(lonlength,latlength,altlength)) +allocate(angprimvprimmean(lonlength,latlength,altlength)) +allocate(angprimwprimmean(lonlength,latlength,altlength)) +allocate( vstarmean(lonlength,latlength,altlength)) +allocate( wstarmean(lonlength,latlength,altlength)) +allocate(angstarmean(lonlength,latlength,altlength)) +allocate(angstarmeanvstarmean(lonlength,latlength,altlength)) +allocate(angstarmeanwstarmean(lonlength,latlength,altlength)) +allocate( v3d(lonlength,latlength,altlength)) +allocate( w3d(lonlength,latlength,altlength)) +allocate(ang3d(lonlength,latlength,altlength)) + +! lat,alt,time +allocate( vbar(latlength,altlength,timelength)) +allocate( wbar(latlength,altlength,timelength)) +allocate(angbar(latlength,altlength,timelength)) + +!lat,alt +allocate( vmeanbar(latlength,altlength)) +allocate( wmeanbar(latlength,altlength)) +allocate(angmeanbar(latlength,altlength)) +allocate( vbar2d(latlength,altlength)) +allocate( wbar2d(latlength,altlength)) +allocate(angbar2d(latlength,altlength)) + +allocate(totvang(latlength,altlength)) +allocate(totwang(latlength,altlength)) +allocate(mmcvang(latlength,altlength)) +allocate(mmcwang(latlength,altlength)) +allocate(trsvang(latlength,altlength)) +allocate(trswang(latlength,altlength)) +allocate(stnvang(latlength,altlength)) +allocate(stnwang(latlength,altlength)) + +! intermediates +!----------------- + +do itim=1,timelength + v3d(:,:,:) = vitv(:,:,:,itim) + w3d(:,:,:) = vitw(:,:,:,itim) + ang3d(:,:,:) = tsam(:,:,:,itim) + call moyzon2(lonlength,latlength,altlength,miss_val, v3d, vbar2d) + call moyzon2(lonlength,latlength,altlength,miss_val, w3d, wbar2d) + call moyzon2(lonlength,latlength,altlength,miss_val,ang3d,angbar2d) + vbar(:,:,itim) = vbar2d(:,:) + wbar(:,:,itim) = wbar2d(:,:) + angbar(:,:,itim) = angbar2d(:,:) +enddo ! timelength + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + do itim=1,timelength + if ((vitv(ilon,ilat,ilev,itim).ne.miss_val).and. & + (vbar(ilat,ilev,itim) .ne.miss_val)) then + vstar(ilon,ilat,ilev,itim) = vitv(ilon,ilat,ilev,itim)- vbar(ilat,ilev,itim) + else + vstar(ilon,ilat,ilev,itim) = miss_val + endif + if ((vitw(ilon,ilat,ilev,itim).ne.miss_val).and. & + (wbar(ilat,ilev,itim) .ne.miss_val)) then + wstar(ilon,ilat,ilev,itim) = vitw(ilon,ilat,ilev,itim)- wbar(ilat,ilev,itim) + else + wstar(ilon,ilat,ilev,itim) = miss_val + endif + if (( tsam(ilon,ilat,ilev,itim).ne.miss_val).and. & + (angbar(ilat,ilev,itim) .ne.miss_val)) then + angstar(ilon,ilat,ilev,itim) = tsam(ilon,ilat,ilev,itim)-angbar(ilat,ilev,itim) + else + angstar(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo + enddo +enddo ! lonlength +call moytim(lonlength,latlength,altlength,timelength,miss_val, vstar, vstarmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val, wstar, wstarmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val,angstar,angstarmean) +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + if ((angstarmean(ilon,ilat,ilev).ne.miss_val).and. & + ( vstarmean(ilon,ilat,ilev).ne.miss_val)) then +angstarmeanvstarmean(ilon,ilat,ilev) = angstarmean(ilon,ilat,ilev)*vstarmean(ilon,ilat,ilev) + else +angstarmeanvstarmean(ilon,ilat,ilev) = miss_val + endif + if ((angstarmean(ilon,ilat,ilev).ne.miss_val).and. & + ( wstarmean(ilon,ilat,ilev).ne.miss_val)) then +angstarmeanwstarmean(ilon,ilat,ilev) = angstarmean(ilon,ilat,ilev)*wstarmean(ilon,ilat,ilev) + else +angstarmeanwstarmean(ilon,ilat,ilev) = miss_val + endif + enddo + enddo +enddo ! lonlength + +call moytim(lonlength,latlength,altlength,timelength,miss_val,vitv, vmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val,vitw, wmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val,tsam,angmean) +call moyzon2(lonlength,latlength,altlength,miss_val, vmean, vmeanbar) +call moyzon2(lonlength,latlength,altlength,miss_val, wmean, wmeanbar) +call moyzon2(lonlength,latlength,altlength,miss_val,angmean,angmeanbar) + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + do itim=1,timelength + if ((vitv(ilon,ilat,ilev,itim).ne.miss_val).and. & + (tsam(ilon,ilat,ilev,itim).ne.miss_val)) then +vang(ilon,ilat,ilev,itim) = vitv(ilon,ilat,ilev,itim)*tsam(ilon,ilat,ilev,itim) + else +vang(ilon,ilat,ilev,itim) = miss_val + endif + if ((vitw(ilon,ilat,ilev,itim).ne.miss_val).and. & + (tsam(ilon,ilat,ilev,itim).ne.miss_val)) then +wang(ilon,ilat,ilev,itim) = vitw(ilon,ilat,ilev,itim)*tsam(ilon,ilat,ilev,itim) + else +wang(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo + enddo +enddo ! lonlength +call moytim(lonlength,latlength,altlength,timelength,miss_val,vang,vangmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val,wang,wangmean) + +do ilon=1,lonlength + do ilat=1,latlength + do ilev=1,altlength + do itim=1,timelength + if ((vitv(ilon,ilat,ilev,itim).ne.miss_val).and. & + (vmean(ilon,ilat,ilev) .ne.miss_val)) then + vprim(ilon,ilat,ilev,itim) = vitv(ilon,ilat,ilev,itim)- vmean(ilon,ilat,ilev) + else + vprim(ilon,ilat,ilev,itim) = miss_val + endif + if ((vitw(ilon,ilat,ilev,itim).ne.miss_val).and. & + (wmean(ilon,ilat,ilev) .ne.miss_val)) then + wprim(ilon,ilat,ilev,itim) = vitw(ilon,ilat,ilev,itim)- wmean(ilon,ilat,ilev) + else + wprim(ilon,ilat,ilev,itim) = miss_val + endif + if ((tsam(ilon,ilat,ilev,itim).ne.miss_val).and. & + (angmean(ilon,ilat,ilev) .ne.miss_val)) then +angprim(ilon,ilat,ilev,itim) = tsam(ilon,ilat,ilev,itim)-angmean(ilon,ilat,ilev) + else +angprim(ilon,ilat,ilev,itim) = miss_val + endif + if ((angprim(ilon,ilat,ilev,itim).ne.miss_val).and. & + ( vprim(ilon,ilat,ilev,itim).ne.miss_val)) then +angprimvprim(ilon,ilat,ilev,itim) = angprim(ilon,ilat,ilev,itim)*vprim(ilon,ilat,ilev,itim) + else +angprimvprim(ilon,ilat,ilev,itim) = miss_val + endif + if ((angprim(ilon,ilat,ilev,itim).ne.miss_val).and. & + ( wprim(ilon,ilat,ilev,itim).ne.miss_val)) then +angprimwprim(ilon,ilat,ilev,itim) = angprim(ilon,ilat,ilev,itim)*wprim(ilon,ilat,ilev,itim) + else +angprimwprim(ilon,ilat,ilev,itim) = miss_val + endif + enddo + enddo + enddo +enddo ! lonlength +call moytim(lonlength,latlength,altlength,timelength,miss_val,& + angprimvprim,angprimvprimmean) +call moytim(lonlength,latlength,altlength,timelength,miss_val,& + angprimwprim,angprimwprimmean) + +! ang transport terms +!---------------------- + +call moyzon2(lonlength,latlength,altlength,miss_val,vangmean,totvang) +call moyzon2(lonlength,latlength,altlength,miss_val,wangmean,totwang) + +do ilat=1,latlength + do ilev=1,altlength + if ((angmeanbar(ilat,ilev).ne.miss_val).and. & + ( vmeanbar(ilat,ilev).ne.miss_val)) then +mmcvang(ilat,ilev) = angmeanbar(ilat,ilev)*vmeanbar(ilat,ilev) + else +mmcvang(ilat,ilev) = miss_val + endif + if ((angmeanbar(ilat,ilev).ne.miss_val).and. & + ( wmeanbar(ilat,ilev).ne.miss_val)) then +mmcwang(ilat,ilev) = angmeanbar(ilat,ilev)*wmeanbar(ilat,ilev) + else +mmcwang(ilat,ilev) = miss_val + endif + enddo +enddo + +call moyzon2(lonlength,latlength,altlength,miss_val,angprimvprimmean,trsvang) +call moyzon2(lonlength,latlength,altlength,miss_val,angprimwprimmean,trswang) + +call moyzon2(lonlength,latlength,altlength,miss_val,angstarmeanvstarmean,stnvang) +call moyzon2(lonlength,latlength,altlength,miss_val,angstarmeanwstarmean,stnwang) + + +print*,"End of computations" + +!=============================================================================== +! 3. Create output file +!=============================================================================== + +! Create output file +ierr=NF_CREATE(outfile,NF_CLOBBER,outfid) +if (ierr.ne.NF_NOERR) then + write(*,*)"Error: could not create file ",outfile + stop +endif + +!=============================================================================== +! 3.1. Define and write dimensions +!=============================================================================== + +call write_dim(outfid,lonlength,latlength,altlength,timelength, & + lon,lat,plev,time,lon_dimid,lat_dimid,alt_dimid,time_dimid) + +!=============================================================================== +! 3.2. Define and write variables +!=============================================================================== + +datashape2d(1)=lat_dimid +datashape2d(2)=alt_dimid + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "totvang ", "tot hor trpt of ang ","m3 s-2 ",miss_val,& + totvang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "totwang ", "tot ver trpt of ang ","m3 s-2 ",miss_val,& + totwang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "mmcvang ", "MMC hor trpt of ang ","m3 s-2 ",miss_val,& + mmcvang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "mmcwang ", "MMC ver trpt of ang ","m3 s-2 ",miss_val,& + mmcwang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "trsvang ", "trs hor trpt of ang ","m3 s-2 ",miss_val,& + trsvang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "trswang ", "trs ver trpt of ang ","m3 s-2 ",miss_val,& + trswang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "stnvang ", "stn hor trpt of ang ","m3 s-2 ",miss_val,& + stnvang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "stnwang ", "stn ver trpt of ang ","m3 s-2 ",miss_val,& + stnwang ) + +call write_var2d(outfid,datashape2d,latlength,altlength,& + "dmass ", "mass in each cell ","kg ",miss_val,& + dmassmeanbar ) + + +!!!! Close output file +ierr=NF_CLOSE(outfid) +if (ierr.ne.NF_NOERR) write(*,*) 'Error, failed to close output file ',outfile + + +end program Index: trunk/LMDZ.TITAN.old/Tools/venus.h =================================================================== --- trunk/LMDZ.TITAN.old/Tools/venus.h (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/venus.h (revision 1643) @@ -0,0 +1,22 @@ +! Parameters needed to integrate hydrostatic equation: + +real,parameter :: g0=8.87 +!g0: exact mean gravity at radius=6051.km + +real,parameter :: a0=6051.E3 +!a0: 'mean' radius=6051.km + +real,parameter :: R0=191.4 ! molecular gas constant + +real,parameter :: psref=9.2e6 ! reference pressure at surface (Pa) + +real,parameter :: omega=2.992677e-7 ! angular rotation speed (s-1) + +real,parameter :: localday=1.0087e7 ! local day (s) + +character (len=5),parameter :: planet="Venus" + +real,parameter :: cp0=1000. !doit etre egal a cpp (dyn) et RCPD (phy) +real,parameter :: t0=460. +real,parameter :: nu=0.35 + Index: trunk/LMDZ.TITAN.old/Tools/zrecast-titan.input =================================================================== --- trunk/LMDZ.TITAN.old/Tools/zrecast-titan.input (revision 1643) +++ trunk/LMDZ.TITAN.old/Tools/zrecast-titan.input (revision 1643) @@ -0,0 +1,62 @@ +histmth.12.A.nc +titan +all +1 +no +55 +146000. +140000. +136000. +130000. +122162. +113010. +102282. + 90554. + 78473. + 66644. + 55554. + 45539. + 36778. + 29317. + 23108. + 18039. + 13967. + 10739. + 8210. + 6247. + 4734. + 3575. + 2693. + 2023. + 1518. + 1137. + 851. + 636. + 475. + 354. + 264. + 197. + 147. + 109. + 82. + 61. + 45. + 34. + 25. + 19. + 14. + 10. + 8. + 6. + 4. + 3. + 2.4 + 1.8 + 1.3 + 0.98 + 0.72 + 0.51 + 0.33 + 0.16 + 0.04 + Index: trunk/LMDZ.TITAN.old/arch =================================================================== --- trunk/LMDZ.TITAN.old/arch (revision 1643) +++ trunk/LMDZ.TITAN.old/arch (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/arch Index: trunk/LMDZ.TITAN.old/bld.cfg =================================================================== --- trunk/LMDZ.TITAN.old/bld.cfg (revision 1643) +++ trunk/LMDZ.TITAN.old/bld.cfg (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/bld.cfg Index: trunk/LMDZ.TITAN.old/build_gcm =================================================================== --- trunk/LMDZ.TITAN.old/build_gcm (revision 1643) +++ trunk/LMDZ.TITAN.old/build_gcm (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/build_gcm Index: trunk/LMDZ.TITAN.old/create_make_gcm =================================================================== --- trunk/LMDZ.TITAN.old/create_make_gcm (revision 1643) +++ trunk/LMDZ.TITAN.old/create_make_gcm (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/create_make_gcm Index: trunk/LMDZ.TITAN.old/deftank/gcm.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/gcm.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/gcm.def (revision 1643) @@ -0,0 +1,87 @@ +## $Header$ +# +## Planete: +planet_type=titan +# +## nombre de pas par jour (multiple de iperiod) ( ici pour dt ~ 2 min ) +day_step=8000 +## periode pour le pas Matsuno (en pas) +iperiod=5 +## periode de la dissipation (en pas) PAR DEFAUT: 0 ie calcul autom. +## dissip_period=5 +## choix de l'operateur de dissipation (star ou non star ) +lstardis=y +## nombre d'iterations de l'operateur de dissipation gradiv +nitergdiv=1 +## nombre d'iterations de l'operateur de dissipation nxgradrot +nitergrot=2 +## nombre d'iterations de l'operateur de dissipation divgrad +niterh=2 +## temps de dissipation des plus petites long.d ondes pour u,v (gradiv) +tetagdiv=2.e5 +## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot) +tetagrot=2.e5 +## temps de dissipation des plus petites long.d ondes pour h ( divgrad) +tetatemp=2.e5 +## coefficient pour gamdissip +coefdis=0. +## choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) +purmats=n +## avec ou sans physique +## 0: pas de physique (e.g. en mode Shallow Water) +## 1: avec physique (e.g. physique phylmd) +## 2: avec rappel newtonien dans la dynamique +iflag_phys=1 +## avec ou sans fichiers de demarrage (start.nc, startphy.nc) ? +## (sans fichiers de demarrage, initialisation des champs par iniacademic +## dans la dynamique) PAS AU POINT POUR TITAN +read_start=y +## periode de la physique (en pas) +iphysiq=40 +## avec ou sans traceurs +iflag_trac=1 +## Avec ou sans strato // i.e. Couche eponge et second palier pour dissip horiz. +ok_strato=y +## Dissipation horizontale +dissip_fac_mid=2. +dissip_fac_up=10. +# deltaz et hdelta en km +dissip_deltaz=10. +dissip_hdelta=5. +# pupstart en Pa +dissip_pupstart=1.e2 +## Couche eponge +# 1: dans les 4 derniers niveaux +# 2: dans les couches de pression plus faible que 100 fois la pression de la derniere couche +iflag_top_bound=1 +## Mode Couche eponge +# mode = 0 : pas de sponge +# mode = 1 : u et v -> 0 +# mode = 2 : u et v -> moyenne zonale +# mode = 3 : u, v et h -> moyenne zonale +mode_top_bound=1 +# Coefficient pour la couche eponge (valeur derniere couche) +tau_top_bound=4.e-5 +## Maree gravitationnelle ou non +tidal=y + +## longitude en degres du centre du zoom +clon=0. +## latitude en degres du centre du zoom +clat=0. +## facteur de grossissement du zoom,selon longitude +grossismx=1.0 +## facteur de grossissement du zoom ,selon latitude +grossismy=1.0 +## Fonction f(y) hyperbolique si = .true. , sinon sinusoidale +fxyhypb=y +## extension en longitude de la zone du zoom ( fraction de la zone totale) +dzoomx=0.0 +## extension en latitude de la zone du zoom ( fraction de la zone totale) +dzoomy=0.0 +##raideur du zoom en X +taux=3. +##raideur du zoom en Y +tauy=3. +## Fonction f(y) avec y = Sin(latit.) si = .true. , sinon y = latit. +ysinus=y Index: trunk/LMDZ.TITAN.old/deftank/physiq.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/physiq.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/physiq.def (revision 1643) @@ -0,0 +1,115 @@ +## $Header: /home/cvsroot/LMDZ4/physiq.def,v 1.2 2004/06/22 11:45:18 lmdzadmin Exp $ +# +# PARAMETRES ANCIENNEMENT DANS gcm.def +## Cycle diurne ou non +cycle_diurne=y +## Soil Model ou non +soil_model=y +## Orodr ou non pour l orographie +ok_orodr=n +## Orolf ou non pour l orographie +ok_orolf=n +## Gravity Waves non-orographiques +ok_gw_nonoro=n +## Nombre d'appels des routines de rayonnements ( par jour) +nbapp_rad=20 +## Nombre d'appels des routines de chimie ( par jour) +nbapp_chim=1 +## Flag pour la convection : 1 pour LMD, 2 pour Tiedtke, 3 KE(nvlle version JYG), 30 KE(version IPCC AR4), 4 KE vect +iflag_con=0 +# +# +# Parametres fichiers de sortie +# +### OK_mensuel= y sortir fichier mensuel histmth.nc, =n pas de fichier histmth.nc +OK_mensuel=y +### OK_journe= y sortir fichier journalier histday.nc, =n pas de fichier histday.nc +OK_journe=y +### OK_instan=y, ecrire sorties "instantanees" (chaque pas de temps de la physique) +OK_instan=n +# frequence ecriture du fichier histins en jours +ecritphy=0.01 +# +# Parametres niveau de sorties differents fichiers +# +#niveau de sortie "mth" lev_histmth +# - lev_histmth=1 => basiques, 2D +# - lev_histmth=2 => basiques, 3D (defaut) +# - lev_histmth=3 => transfert radiatif +# - lev_histmth=4 => champs tendances 3d +# - lev_histmth=5 => traceurs, autres +lev_histmth=4 +# +#niveau de sortie "day" ET "ins" lev_histday +# - lev_histday=1 => basiques, 2D +# - lev_histday=2 => basiques, 3D (defaut) +# - lev_histday=3 => transfert radiatif +# - lev_histday=4 => champs tendances 3d +# - lev_histday=5 => traceurs, autres +lev_histday=2 +# +# parametres climatiques +# +# TITAN ## +year_day = 673. +peri_day = 536. +periheli = 1354.5 +aphelie = 1506.0 +obliquit = 26.7 +# solaire: effective, rapportee a 1 UA A REVOIR +solaire = 2620. +# +# parametres boundary layer +# +iflag_pbl = 8 +z0 = 0.005 +lmixmin = 35. +ksta = 1.e-7 +ok_kzmin=n +# +inertie=2000. +emis=0.95 +# +# parametres convection seche +# +iflag_ajs = 1 +# +# parametres chimie +# +# si chimi=y, il faut moyzon_ch=y +chimi = n +moyzon_ch=n +# version chimie -> 1=complete / 2=pseudo (rappel) +vchim = 1 +# production des aerosols par la chimie +aerprod=0 +# recombinaison heterogene H->H2 +htoh2 = 0 +# T=utilise Lell dans radtitan, F= utilise la compo incluse +ylellouch=y +# (si ylell=F) prise en compte de HCN dans le transfert radiatif +hcnrad = n +# +# parametres microphysique +# +# si microfi=1, il faut moyzon_mu=y +# si microfi=2, il faut moyzon_mu=n +microfi=1 +moyzon_mu=y +# facteur pour les aerosols +tx = 3. +# facteur de correction +tcorrect=1. +# Facteur d ajustement des proprietes vis des aerosols +xvis=1. +# Facteur d ajustement des proprietes IR des aerosols +xir=1. +# pressure level for aerosol production (in Pa) +p_prodaer=1. +# 0: pas de cutoff ; 1 pour albedo ok ; 2 pour T tropopause ok +cutoff=2 +# activation nuages (si 1, mettre cutoff=0) +clouds=0 +# fraction nuageuse +xnuf=0.5 + Index: trunk/LMDZ.TITAN.old/deftank/rcm1d.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/rcm1d.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/rcm1d.def (revision 1643) @@ -0,0 +1,18 @@ +0 ! Date de depart +0 ! heure de debut de simulation +2000 ! nombre de pas de temps / jour +2 ! nombre de jours simules +1.4e5 ! psurf +40 ! Latitude +0.1 ! composante vers l est du vent geostrophique (U) +0.1 ! composante vers le nord du vent geostrophique (V) + +! parametres pour profile.F + +1 ! profil de T +70. ! tref, sert pour T=cst +0 ! isin (pour perturbation) +0. ! pic pour perturbation gaussienne +0. ! largeur pour perturbation gaussienne +0. ! hauteur pour perturbation gaussienne + Index: trunk/LMDZ.TITAN.old/deftank/run.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/run.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/run.def (revision 1643) @@ -0,0 +1,31 @@ +# +# $Header: /users/lmdz/cvsroot/LMDZ.3.3/run.def,v 1.2.2.3 2002/07/12 14:11:18 lmdzadmin Exp $ +# +INCLUDEDEF=physiq.def +INCLUDEDEF=gcm.def +## Calendrier +## calend=titan +## Jour de l'etat initial ( = 350 si 20 Decembre ,par expl. ,comme ici ) +dayref=1 +## Annee de l'etat initial ( avec 4 chiffres ) +anneeref=1111 +## Remise a zero de la date initiale +raz_date=0 +## Reinit des variables de controle +resetvarc=n +## Nombre de jours d'integration +nday=11 +## periode de sortie des variables de controle (en pas) +iconser=500 +# +## sorties instantanees dans la dynamique (fichiers dyn_hist.nc and co.) +ok_dyn_ins=n +## periode d'ecriture des sorties instantanees dans la dynamique +## (en pas dynamiques) +iecri= 500 +## sorties de valeurs moyennes dans la dynamique (fichiers dyn_hist_ave.nc and co.) +ok_dyn_ave=n +## periode de stockage des moyennes dans la dynamique et dans dynzon (en jour) +periodav= 10. +## flag de sortie dynzon +ok_dynzon=n Index: trunk/LMDZ.TITAN.old/deftank/traceur.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/traceur.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/traceur.def (revision 1643) @@ -0,0 +1,55 @@ +54 +10 10 q01 +10 10 q02 +10 10 q03 +10 10 q04 +10 10 q05 +10 10 q06 +10 10 q07 +10 10 q08 +10 10 q09 +10 10 q10 +10 10 H +10 10 H2 +10 10 CH +10 10 CH2s +10 10 CH2 +10 10 CH3 +10 10 CH4 +10 10 C2 +10 10 C2H +10 10 C2H2 +10 10 C2H3 +10 10 C2H4 +10 10 C2H5 +10 10 C2H6 +10 10 C3H3 +10 10 C3H5 +10 10 C3H6 +10 10 C3H7 +10 10 C4H +10 10 C4H3 +10 10 C4H4 +10 10 C4H2s +10 10 CH2CCH2 +10 10 CH3CCH +10 10 C3H8 +10 10 C4H2 +10 10 C4H6 +10 10 C4H10 +10 10 AC6H6 +10 10 C3H2 +10 10 C4H5 +10 10 AC6H5 +10 10 N2 +10 10 N4S +10 10 CN +10 10 HCN +10 10 H2CN +10 10 CHCN +10 10 CH2CN +10 10 CH3CN +10 10 C3N +10 10 HC3N +10 10 NCCN +10 10 C4N2 Index: trunk/LMDZ.TITAN.old/deftank/traceur.def.chimie_noclouds =================================================================== --- trunk/LMDZ.TITAN.old/deftank/traceur.def.chimie_noclouds (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/traceur.def.chimie_noclouds (revision 1643) @@ -0,0 +1,55 @@ +54 +10 10 q01 +10 10 q02 +10 10 q03 +10 10 q04 +10 10 q05 +10 10 q06 +10 10 q07 +10 10 q08 +10 10 q09 +10 10 q10 +10 10 H +10 10 H2 +10 10 CH +10 10 CH2s +10 10 CH2 +10 10 CH3 +10 10 CH4 +10 10 C2 +10 10 C2H +10 10 C2H2 +10 10 C2H3 +10 10 C2H4 +10 10 C2H5 +10 10 C2H6 +10 10 C3H3 +10 10 C3H5 +10 10 C3H6 +10 10 C3H7 +10 10 C4H +10 10 C4H3 +10 10 C4H4 +10 10 C4H2s +10 10 CH2CCH2 +10 10 CH3CCH +10 10 C3H8 +10 10 C4H2 +10 10 C4H6 +10 10 C4H10 +10 10 AC6H6 +10 10 C3H2 +10 10 C4H5 +10 10 AC6H5 +10 10 N2 +10 10 N4S +10 10 CN +10 10 HCN +10 10 H2CN +10 10 CHCN +10 10 CH2CN +10 10 CH3CN +10 10 C3N +10 10 HC3N +10 10 NCCN +10 10 C4N2 Index: trunk/LMDZ.TITAN.old/deftank/traceur.def.clouds_nochimie =================================================================== --- trunk/LMDZ.TITAN.old/deftank/traceur.def.clouds_nochimie (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/traceur.def.clouds_nochimie (revision 1643) @@ -0,0 +1,55 @@ +53 +10 10 q01 +10 10 q02 +10 10 q03 +10 10 q04 +10 10 q05 +10 10 q06 +10 10 q07 +10 10 q08 +10 10 q09 +10 10 q10 +10 10 q11 +10 10 q12 +10 10 q13 +10 10 q14 +10 10 q15 +10 10 q16 +10 10 q17 +10 10 q18 +10 10 q19 +10 10 q20 +10 10 q21 +10 10 q22 +10 10 q23 +10 10 q24 +10 10 q25 +10 10 q26 +10 10 q27 +10 10 q28 +10 10 q29 +10 10 q30 +10 10 q31 +10 10 q32 +10 10 q33 +10 10 q34 +10 10 q35 +10 10 q36 +10 10 q37 +10 10 q38 +10 10 q39 +10 10 q40 +10 10 q41 +10 10 q42 +10 10 q43 +10 10 q44 +10 10 q45 +10 10 q46 +10 10 q47 +10 10 q48 +10 10 q49 +10 10 q50 +10 10 CH4 +10 10 C2H6 +10 10 C2H2 + Index: trunk/LMDZ.TITAN.old/deftank/traceur.def.nochimie_noclouds =================================================================== --- trunk/LMDZ.TITAN.old/deftank/traceur.def.nochimie_noclouds (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/traceur.def.nochimie_noclouds (revision 1643) @@ -0,0 +1,11 @@ +10 +10 10 q01 +10 10 q02 +10 10 q03 +10 10 q04 +10 10 q05 +10 10 q06 +10 10 q07 +10 10 q08 +10 10 q09 +10 10 q10 Index: trunk/LMDZ.TITAN.old/deftank/z2sig.def =================================================================== --- trunk/LMDZ.TITAN.old/deftank/z2sig.def (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/z2sig.def (revision 1643) @@ -0,0 +1,56 @@ + 40.00000 H: atmospheric scale height (km) (used as a reference only) + 0.040000000 Typical log(sigma) for 1st layer (z=H*log(sigma)) + 0.240000000 Typical log(sigma) for 2nd layer, etc... + 0.640000000 + 1.600000000 + 3.600000000 + 7.200000000 + 12.457209840 + 17.390108120 + 23.191633240 + 29.808692920 + 37.172176840 + 45.206308400 + 53.831887200 + 62.973513600 + 72.558302800 + 82.522678400 + 92.806120000 +103.360567200 +114.137802000 +125.105094800 +136.223478400 +147.474737200 +158.824243600 +170.268688400 +181.771335600 +193.346900800 +204.947319200 +216.613330800 +228.270988400 +240.003299600 +251.685886400 +263.474598000 +275.151500800 +287.001610000 +298.636570000 +310.572548000 +322.112846400 +334.189224400 +345.548553600 +357.870636000 +368.899574400 +381.662178000 +392.096252400 +405.654832000 +417.023764000 +430.028000000 +443.499352000 +456.162812000 +469.293936000 +472.097320000 +485.525628000 +510.559464000 +525.345664000 +540.110748000 +556.096956000 Index: trunk/LMDZ.TITAN.old/deftank/z2sig.def.55 =================================================================== --- trunk/LMDZ.TITAN.old/deftank/z2sig.def.55 (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/z2sig.def.55 (revision 1643) @@ -0,0 +1,56 @@ + 40.00000 H: atmospheric scale height (km) (used as a reference only) + 0.040000000 Typical log(sigma) for 1st layer (z=H*log(sigma)) + 0.240000000 Typical log(sigma) for 2nd layer, etc... + 0.640000000 + 1.600000000 + 3.600000000 + 7.200000000 + 12.457209840 + 17.390108120 + 23.191633240 + 29.808692920 + 37.172176840 + 45.206308400 + 53.831887200 + 62.973513600 + 72.558302800 + 82.522678400 + 92.806120000 +103.360567200 +114.137802000 +125.105094800 +136.223478400 +147.474737200 +158.824243600 +170.268688400 +181.771335600 +193.346900800 +204.947319200 +216.613330800 +228.270988400 +240.003299600 +251.685886400 +263.474598000 +275.151500800 +287.001610000 +298.636570000 +310.572548000 +322.112846400 +334.189224400 +345.548553600 +357.870636000 +368.899574400 +381.662178000 +392.096252400 +405.654832000 +417.023764000 +430.028000000 +443.499352000 +456.162812000 +469.293936000 +472.097320000 +485.525628000 +510.559464000 +525.345664000 +540.110748000 +556.096956000 Index: trunk/LMDZ.TITAN.old/deftank/z2sig.def.65 =================================================================== --- trunk/LMDZ.TITAN.old/deftank/z2sig.def.65 (revision 1643) +++ trunk/LMDZ.TITAN.old/deftank/z2sig.def.65 (revision 1643) @@ -0,0 +1,66 @@ + 40.00000 H: atmospheric scale height (km) (used as a reference only) + 0.040000000 Typical log(sigma) for 1st layer (z=H*log(sigma)) + 0.240000000 Typical log(sigma) for 2nd layer, etc... + 0.640000000 + 1.600000000 + 3.600000000 + 7.200000000 + 12.457209840 + 17.390108120 + 23.191633240 + 29.808692920 + 37.172176840 + 45.206308400 + 53.831887200 + 62.973513600 + 72.558302800 + 82.522678400 + 92.806120000 +103.360567200 +114.137802000 +125.105094800 +136.223478400 +147.474737200 +158.824243600 +170.268688400 +181.771335600 +193.346900800 +204.947319200 +216.613330800 +228.270988400 +240.003299600 +251.685886400 +263.474598000 +275.151500800 +287.001610000 +298.636570000 +310.572548000 +322.112846400 +334.189224400 +345.548553600 +357.870636000 +368.899574400 +381.662178000 +392.096252400 +405.654832000 +417.023764000 +430.028000000 +443.499352000 +456.162812000 +469.293936000 +472.097320000 +485.525628000 +510.559464000 +525.345664000 +540.110748000 +556.096956000 +570. +585. +600. +615. +630. +645. +660. +675. +690. +705. Index: trunk/LMDZ.TITAN.old/libf/chimtitan/aer.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/aer.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/aer.c (revision 1643) @@ -0,0 +1,206 @@ +/* aer: production of aerosol precursors by photochemistry */ + +#include "titan.h" + +void aer( char corps[][10], double *tp, double *nb, double y[][NLEV], + int *zj, double **k_dep, double **f, + double *r1, double *r2, double *r3, double *r4, double *r5, double *r6, + int *utilaer, double *m, double *prod, double *csn, double *csh ) +{ + int re,x,z; + int i,j,c2h2,c2,c2h,hc3n,c3n,c4h2,hcn,h2cn,c4h3,ac6h5,ac6h6; + int nccn,ch3cn,c2h3cn,NMAX; + double v1,v2,v3,alpha,beta1,beta2,gamma,denom; + double temp,ct,dy_c2h2,dy_hc3n,dy_hcn; + double dy_nccn,dy_ch3cn,dy_c2h3cn; + char sor1[20],sor2[20],sor3[20],outlog[10]; + FILE *fp, *out; + + NMAX = 20; + z = (*zj); + temp = tp[z]; + ct = nb[z]; + +/* debug + out = fopen( "aer.log", "a" ); + fprintf( out, "" ); + fclose( out ); +*/ + +/* composes interessants */ +/* --------------------- */ +/* !! decalage de 1 par rapport a calchim !! */ + + c2h2 = utilaer[2]; + c2 = utilaer[3]; + c2h = utilaer[4]; + hc3n = utilaer[5]; + hcn = utilaer[6]; + c3n = utilaer[7]; + h2cn = utilaer[8]; + c4h2 = utilaer[9]; + c4h3 = utilaer[10]; + ac6h5 = utilaer[11]; + ac6h6 = utilaer[12]; + nccn = utilaer[13]; + ch3cn = utilaer[14]; + c2h3cn = utilaer[15]; + + +/* si C2H3CN n'est pas pris en compte: attribue a CH3CN, mais reaction nulle */ + +/* vitesses de reactions */ +/* --------------------- */ + + /* v (et K) en cm3.s-1 */ + v1 = 2.e-16; + v2 = 3.72e-13*exp(-1561./temp); + v3 = 1.0e-12*exp(-900./temp); + + alpha = 6.; + beta1 = 1.; + beta2 = 1.; + gamma = 1.; + + /* k en s-1 */ + k_dep[1][1] = v1 *ct*y[c2h2][z]*y[c4h3][z]; /* C2H2 + C4H3 */ + k_dep[2][1] = v1 *ct*y[hc3n][z]*y[c4h3][z] *alpha; /* HC3N + C4H3 */ + for( i = 3; i <= 5; i++ ) k_dep[i][1] = 0.; + + k_dep[1][2] = v2 *ct*y[c2h2][z]*y[ac6h5][z]; /* C2H2 + AC6H5 */ + k_dep[2][2] = v2 *ct* y[hcn][z]*y[ac6h5][z]*beta1; /* HCN + AC6H5 */ + k_dep[3][2] = v2 *ct*y[hc3n][z]*y[ac6h5][z]*beta2; /* HC3N + AC6H5 */ +/* for( i = 4; i <= 5; i++ ) k_dep[i][2] = 0.; */ + k_dep[4][2] = 5.2e-10 *ct* y[c2][z]*y[ac6h6][z]; /* C2 + AC6H6 */ + k_dep[5][2] = 8.2e-11 *ct*y[c2h][z]*y[ac6h6][z]; /* C2H + AC6H6 */ + + k_dep[1][3] = v3 *ct* y[hcn][z]*y[h2cn][z]; /* HCNH + HCN */ +/* !! debug !! + k_dep[2][3] = v3 *ct*y[hc3n][z]*y[h2cn][z]*gamma; HCNH + HC3N */ + k_dep[2][3] = v3 *ct*y[hc3n][z]*y[h2cn][z]*1.e-10; /* HCNH + HC3N */ + k_dep[3][3] = v3 *ct*y[nccn][z]*y[h2cn][z]*gamma; /* HCNH + NCCN */ + k_dep[4][3] = v3 *ct*y[ch3cn][z]*y[h2cn][z]*gamma; /* HCNH + CH3CN */ + if(c2h3cn!=ch3cn) + k_dep[5][3] = v3*ct*y[c2h3cn][z]*y[h2cn][z]*gamma; /* HCNH + C2H3CN */ + else + k_dep[5][3] = 0.; + +/* Fractions de chaque compose dans les polymeres */ +/* ---------------------------------------------- */ + +/* polyC2H2 */ + + denom = y[c2h2][z] + alpha*y[hc3n][z]; + f[1][1] = y[c2h2][z] / denom; /* C2H2 */ + f[2][1] = alpha*y[hc3n][z] / denom; /* HC3N */ + for( i = 3; i <= 5; i++ ) f[i][1] = 0.; + +/* PAHs */ + + denom = y[c2h2][z] + beta1*y[hcn][z] + beta2*y[hc3n][z]; + f[1][2] = y[c2h2][z] / denom; /* C2H2 */ + f[2][2] = beta1*y[hcn][z] / denom; /* HCN */ + f[3][2] = beta2*y[hc3n][z] / denom; /* HC3N */ + for( i = 4; i <= 5; i++ ) f[i][2] = 0.; + +/* polyHCN */ + + if(c2h3cn!=ch3cn) + denom = y[hcn][z] + gamma*(y[hc3n][z]+y[nccn][z]+y[ch3cn][z]+y[c2h3cn][z]); + else + denom = y[hcn][z] + gamma*(y[hc3n][z]+y[nccn][z]+y[ch3cn][z]); + f[1][3] = y[hcn][z] / denom; /* HCN */ + f[2][3] = gamma* y[hc3n][z] / denom; /* HC3N */ + f[3][3] = gamma* y[nccn][z] / denom; /* NCCN */ + f[4][3] = gamma* y[ch3cn][z] / denom; /* CH3CN */ + if(c2h3cn!=ch3cn) + f[5][3] = gamma*y[c2h3cn][z] / denom; /* C2H3CN */ + else + f[5][3] = 0.; /* C2H3CN */ + +/* Masse molaire et Rapports C/N et C/H */ +/* Taux de production en masse */ +/* Taux de destruction molecules */ +/* ------------------------------------ */ + +/* polyC2H2 */ + + m[1] = NMAX*(f[1][1]*26 + f[2][1]*51); /* g.mol-1 */ + + prod[1] = 0.; + for( i = 1; i <= 5; i++ ) prod[1] += k_dep[i][1]; /* s-1 */ + + dy_c2h2 = prod[1] * NMAX * f[1][1]; + dy_hc3n = prod[1] * NMAX * f[2][1]; + + if( f[2][1] != 0.0e0 ) csn[1] = (2*f[1][1] + 3*f[2][1]) / f[2][1]; + else csn[1] = 1.0e30; + csh[1] = (2*f[1][1] + 3*f[2][1]) / (2*f[1][1] + f[2][1]); + +/* PAHs */ + + m[2] = NMAX*(f[1][2]*26 + f[2][2]*27 + f[3][2]*51); /* g.mol-1 */ + + prod[2] = 0.; + for( i = 1; i <= 5; i++ ) prod[2] += k_dep[i][2]; /* s-1 */ + + dy_c2h2 += prod[2] * NMAX * f[1][2]; + dy_hcn = prod[2] * NMAX * f[2][2]; + dy_hc3n += prod[2] * NMAX * f[3][2]; + + if( (f[2][2]+f[3][2]) != 0.0e0 ) + csn[2] = (2*f[1][2] + f[2][2]+ 3*f[3][2]) / (f[2][2] + f[3][2]); + else csn[2] = 1.0e30; + csh[2] = 1.; /* probleme du nombre exact de H */ + +/* polyHCN */ + + m[3] = NMAX*(f[1][3]*27+f[2][3]*51+f[3][3]*52+f[4][3]*41+f[5][3]*53); /* g.mol-1 */ + + prod[3] = 0.; + for( i = 1; i <= 5; i++ ) prod[3] += k_dep[i][3]; /* s-1 */ + + dy_hcn += prod[3] * NMAX * f[1][3]; + dy_hc3n += prod[3] * NMAX * f[2][3]; + dy_nccn = prod[3] * NMAX * f[3][3]; + dy_ch3cn = prod[3] * NMAX * f[4][3]; + dy_c2h3cn= prod[3] * NMAX * f[5][3]; + + csn[3] = (f[1][3]+3*f[2][3]+2*f[3][3]+2*f[4][3]+3*f[5][3]) + / (f[1][3]+ f[2][3]+2*f[3][3]+ f[4][3]+ f[5][3]); + csh[3] = (f[1][3]+3*f[2][3]+2*f[3][3]+2*f[4][3]+3*f[5][3]) + / (f[1][3]+ f[2][3] +3*f[4][3]+3*f[5][3]); + +/* melange */ + + csn[0] = ( prod[1]*(2*f[1][1]+3*f[2][1]) + + prod[2]*(2*f[1][2]+ f[2][2]+3*f[3][2]) + + prod[3]*( f[1][3]+3*f[2][3]+2*f[3][3]+2*f[4][3]+3*f[5][3]) ) + / ( prod[1]*( f[2][1]) + + prod[2]*( f[2][2]+ f[3][2]) + + prod[3]*( f[1][3]+ f[2][3]+2*f[3][3]+ f[4][3]+ f[5][3]) ); + csh[0] = ( prod[1]*(2*f[1][1]+3*f[2][1]) + + prod[2]*(2*f[1][2]+ f[2][2]+3*f[3][2]) + + prod[3]*( f[1][3]+3*f[2][3]+2*f[3][3]+2*f[4][3]+3*f[5][3]) ) + / ( prod[1]*(2*f[1][1]+ f[2][1]) + + prod[2]*(2*f[1][2]+ f[2][2]+ f[3][2]) + + prod[3]*( f[1][3]+ f[2][3] +3*f[4][3]+3*f[5][3]) ); + +/* mass production rates (in kg m-3 s-1) */ + + prod[0] = 0.; + for( i = 1; i <= 3; i++ ) + { + prod[i] = prod[i] * ct * m[i] / 6.022e23 *1.e3; + prod[0] += prod[i]; + } + + *r1 = dy_c2h2; + *r2 = dy_hc3n; + *r3 = dy_hcn; + *r4 = dy_nccn; + *r5 = dy_ch3cn; + *r6 = dy_c2h3cn; + +} + Index: trunk/LMDZ.TITAN.old/libf/chimtitan/chimie.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/chimie.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/chimie.c (revision 1643) @@ -0,0 +1,117 @@ +/* chimie: Chemistry fabric */ +/* GCCM */ + +/* ko: low pressure limit: 3 body reaction (1st) */ +/* ki: high pressure limit: 2 body reaction (2nd) */ + +#include "titan.h" + +void chimie_( char CORPS[][10], double *NB, double *TEMP, double KRATE[][NLEV], int REACTIF[][5], + int *NOM_PERTE, int *NOM_PROD, int PERTE[][200][2], int PROD[][200] ) +{ + int dep,i,j,k,l,lat; + double ai,ao,ei,eo,ki,ko,m,ti,to; + FILE *out; + char corps[100][10]; + static char reaction[NREAC+1][12][10]={ +#include VERCHIM + "", "", "", "", "", "","","","","","",""}; + + for( i = 0; i <= NC; i++) + { + strcpy( corps[i], CORPS[i] ); + corps[i][strcspn(CORPS[i], " ")] = '\0'; + } + + for( i = 0; i <= NC-1; i++ ) + { + NOM_PERTE[i] = NOM_PROD[i] = 0; + for( j = 0; j < 200; j++ ) + PERTE[i][j][0] = PERTE[i][j][1] = PROD[i][j] = 0; + } + dep = 0; + for( i = dep; i <= NREAC-1; i++ ) /* Number of reactions */ + { + for( j = 0; j <= 4; j++ ) /* Number of compouds in each reactions */ + { + k = 0; + if( (strcmp(reaction[i][j],"prod")) /* prod and soot are not */ + && (strcmp(reaction[i][j],"soot")) /* considered in the compounds */ + && (strcmp(reaction[i][j],"")) ) /* Which compound ? */ + { + while( strcmp(reaction[i][j],corps[k]) ) /* Compound in reaction j, column i */ + { + if( k == NC+1 ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "I cannot find %s\n", reaction[i][j] ); + fclose( out ); + exit(0); + } + k++; + } + REACTIF[i][j] = k; /* is number k */ + } + else REACTIF[i][j] = NC; + } + } + for( i = dep; i <= NREAC-1; i++ ) /* Total loss and production */ + { + j = REACTIF[i][0]; /* First compound reaction i */ + k = NOM_PERTE[j] + 1; /* Loss one more times */ + if( k >= 200 ) exit(0); + NOM_PERTE[j] = k; + PERTE[j][k-1][0] = i; /* Compound j loss in reaction i for the kth time */ + PERTE[j][k-1][1] = REACTIF[i][1]; /* Compound j reacts with number 2 in reaction i */ + j = REACTIF[i][1]; /* Second compound reaction i */ + if( j != NC ) /* Neither photodissociation nor desexcitation */ + { + k = NOM_PERTE[j] + 1; /* Loss one more times */ + if( k >= 200 ) exit(0); + NOM_PERTE[j] = k; + PERTE[j][k-1][0] = i; /* Compound j is loss in reaction i for the kth times */ + PERTE[j][k-1][1] = REACTIF[i][0]; /* Compound j reacts with number 1 reaction i */ + } + for( j = 2; j < 5; j++ ) /* Compounds from 3 to 5 */ + { + k = REACTIF[i][j]; /* Number of compound */ + if( k != NC ) + { + l = NOM_PROD[k] + 1; /* One more time produced */ + if( l >= 200 ) exit(0); + NOM_PROD[k] = l; + PROD[k][l-1] = i; /* at reaction i */ + } + } + } + for( i = RDISS+1; i <= NREAC-1; i++ ) /* 0 a RDISS-1: photodiss, RDISS: disso N2 */ + { + ao = strtod(reaction[i][5], NULL); + to = strtod(reaction[i][6], NULL); + eo = strtod(reaction[i][7], NULL); + ai = strtod(reaction[i][8], NULL); + ti = strtod(reaction[i][9], NULL); + ei = strtod(reaction[i][10],NULL); + m = strtod(reaction[i][11],NULL); + for( j = 0; j <= NLEV-1; j++ ) + { + ko = ao * pow( TEMP[j], to) * exp( eo / TEMP[j] ); + if( m == 1.0e0 ) + KRATE[i][j] = ko; + else if( m == 2.0e0 ) + { + KRATE[i][j] = ko * pow( NB[j], 2.0e0 ); + } + else if( m == 3.0e0 ) + { + if( ai == 0.0e0 ) + KRATE[i][j] = ko * pow( NB[j], 3.0e0 ); + else + { + ki = ai * pow( TEMP[j], ti ) * exp( ei / TEMP[j] ); + KRATE[i][j] = pow( NB[j], 3.0e0 ) * ko * ki / ( ko * NB[j] + ki ); + } + } + } + } +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit (revision 1643) @@ -0,0 +1,387 @@ + "H2", "HV", "H", "H", "", "","","","","","","", /* 1 */ + "CH3", "HV", "1CH2", "H", "", "","","","","","","", /* 2 */ + "CH4", "HV", "1CH2", "H2", "", "","","","","","","", /* 3 */ + "CH4", "HV", "CH", "H2", "H", "","","","","","","", /* 4 */ + "CH4", "HV", "CH3", "H", "", "","","","","","","", /* 5 */ + "C2H2", "HV", "C2H", "H", "", "","","","","","","", /* 6 */ + "C2H2", "HV", "C2", "H2", "", "","","","","","","", /* 7 */ + "C2H4", "HV", "C2H2", "H2", "", "","","","","","","", /* 8 */ + "C2H4", "HV", "C2H2", "H", "H", "","","","","","","", /* 9 */ + "C2H6", "HV", "C2H4", "H2", "", "","","","","","","", /* 10 */ + "C2H6", "HV", "C2H4", "H", "H", "","","","","","","", /* 11 */ + "C2H6", "HV", "C2H2", "H2", "H2","","","","","","","", /* 12 */ + "C2H6", "HV", "CH4", "1CH2", "", "","","","","","","", /* 13 */ + "C2H6", "HV", "CH3", "CH3", "", "","","","","","","", /* 14 */ + "C3H3", "HV", "C3H2", "H", "", "","","","","","","", /* 15 */ + "CH2CCH2","HV", "C3H3", "H", "", "","","","","","","", /* 16 */ + "CH2CCH2","HV", "C3H2", "H2", "", "","","","","","","", /* 17 */ + "CH3CCH", "HV", "C3H3", "H", "", "","","","","","","", /* 18 */ + "CH3CCH", "HV", "C3H2", "H2", "", "","","","","","","", /* 19 */ + "C3H6", "HV", "CH2CCH2","H", "H", "","","","","","","", /* 20 */ + "C3H6", "HV", "CH3CCH", "H", "H", "","","","","","","", /* 21 */ + "C3H6", "HV", "C2H4", "3CH2", "", "","","","","","","", /* 22 */ + "C3H6", "HV", "C2H3", "CH3", "", "","","","","","","", /* 23 */ + "C3H6", "HV", "C2H2", "CH4", "", "","","","","","","", /* 24 */ + "C3H8", "HV", "C3H6", "H2", "", "","","","","","","", /* 25 */ + "C3H8", "HV", "C2H6", "1CH2", "", "","","","","","","", /* 26 */ + "C3H8", "HV", "C2H5", "CH3", "", "","","","","","","", /* 27 */ + "C3H8", "HV", "C2H4", "CH4", "", "","","","","","","", /* 28 */ + "C4H2", "HV", "C4H", "H", "", "","","","","","","", /* 29 */ + "C4H2", "HV", "C2H", "C2H", "", "","","","","","","", /* 30 */ + "C4H2", "HV", "C2H2", "C2", "", "","","","","","","", /* 31 */ + "C4H2", "HV", "C4H2s", "", "", "","","","","","","", /* 32 */ + "C4H4", "HV", "C4H2", "H2", "", "","","","","","","", /* 33 */ + "C4H4", "HV", "C2H2", "C2H2", "", "","","","","","","", /* 34 */ + "C4H6", "HV", "C4H4", "H2", "", "","","","","","","", /* 35 */ + "C4H6", "HV", "C2H4", "C2H2", "", "","","","","","","", /* 36 */ + "C4H6", "HV", "CH3", "C3H3", "", "","","","","","","", /* 37 */ + "C4H10", "HV", "C3H5", "CH3", "H2","","","","","","","", /* 38 */ + "C4H10", "HV", "C2H4", "C2H4", "H2","","","","","","","", /* 39 */ + "C4H10", "HV", "C3H6", "CH4", "", "","","","","","","", /* 40 */ + "C4H10", "HV", "C3H6", "CH3", "H", "","","","","","","", /* 41 */ + "C4H10", "HV", "C2H4", "C2H6", "", "","","","","","","", /* 42 */ + "C4H10", "HV", "C2H2", "C2H6", "H2","","","","","","","", /* 43 */ + "C4H10", "HV", "CH3", "C3H7", "", "","","","","","","", /* 44 */ + "C4H10", "HV", "C2H5", "C2H5", "", "","","","","","","", /* 45 */ + + "AC6H6", "HV", "prod", "CH3", "", "","","","","","","", /* 46 */ + "AC6H6", "HV", "AC6H5", "H", "", "","","","","","","", /* 47 */ + + "N2", "HV", "N4S", "N4S", "", "","","","","","","", /* 48 */ + "HCN", "HV", "H", "CN", "", "","","","","","","", /* 49 */ + "HC3N", "HV", "C2H", "CN", "", "","","","","","","", /* 50 */ + "HC3N", "HV", "H", "C3N", "", "","","","","","","", /* 51 */ + "NCCN", "HV", "CN", "CN", "", "","","","","","","", /* 52 */ + "CH3CN", "HV", "CH3", "CN", "", "","","","","","","", /* 53 */ + "C4N2", "HV", "C3N", "CN", "", "","","","","","","", /* 54 */ + + "N2", "", "N4S", "N4S", "", "0.00e+00","+00.0","+00000","0.00e+00","+00.0","+00000","1", + + "H", "H", "H2", "", "", "2.70e-31","-00.6","+00000","1.00e-11","+00.0","+00000","3", /* Baulch92 */ + "H", "1CH2", "CH", "H2", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H", "3CH2", "H2", "CH", "", "3.54e-11","+0.32","+00000","0.00e+00","+00.0","+00000","2", + "H", "3CH2", "CH3", "", "", "1.70e-25","-01.8","+00000","3.50e-11","+0.32","-00000","3", /* cf V05 */ + "H", "CH3", "CH4", "", "", "6.33e-21","-2.98","-00635","2.63e-08","-0.60","-00189","3", + "H", "CH3", "H2", "3CH2", "", "1.00e-10","+00.0","-07600","0.00e+00","+00.0","+00000","2", + "H", "CH4", "H2", "CH3", "", "2.18e-20","+03.0","-04045","0.00e+00","+00.0","+00000","2", + "H", "C2H", "C2H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C2H2", "C2H3", "", "", "3.30e-30","+00.0","-00740","1.40e-11","+00.0","-01300","3", + "H", "C2H3", "H2", "C2H2", "", "6.86e-11","+00.0","+00023","0.00e+00","+00.0","+00000","2", + "H", "C2H3", "C2H4", "", "", "5.76e-24","-01.3","+00000","1.80e-10","+00.0","-00000","3", /* cf M05 */ + "H", "C2H4", "C2H3", "H2", "", "8.40e-17","+1.93","-06518","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "C2H4", "C2H5", "", "", "1.39e-29","+00.0","-00562","6.60e-15","+1.28","-00650","3", + "H", "C2H5", "CH3", "CH3", "", "1.20e-10","+00.0","-00000","0.00e+00","+00.0","+00000","2", /* Sillesen 93 */ + "H", "C2H5", "H2", "C2H4", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C2H5", "C2H6", "", "", "5.50e-23","-2.00","-01040","1.66e-10","+00.0","+00000","3", + "H", "C2H6", "H2", "C2H5", "", "2.40e-15","+01.5","-03730","0.00e+00","+00.0","+00000","2", + "H", "C3H2", "C3H3", "", "", "1.70e-23","-1.80","-00000","1.00e-10","+0.00","+00000","3", /* cf V05 */ + "H", "C3H3", "CH3CCH", "", "", "9.40e-20","-3.30","-00000","1.00e-10","+0.00","+00000","3", /* cf M05 */ + "H", "C3H3", "CH2CCH2","", "", "1.70e-25","-01.8","+00000","2.50e-10","+0.00","-00000","3", /* cf V05 */ + "H", "CH3CCH", "CH3", "C2H2", "", "8.00e-24","-02.0","-01225","9.63e-12","+00.0","-01560","3", /* cf W04 */ + "H", "CH3CCH", "C3H3", "H2", "", "4.70e-16","+1.74","-03873","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "CH3CCH", "C3H5", "", "", "4.40e-31","+00.0","-00000","6.00e-11","+00.0","-01233","3", /* cf V05 */ + "H", "CH2CCH2","C2H2", "CH3", "", "8.00e-24","-2.00","-01225","9.70e-13","+0.00","-01550","3", /* cf W04 */ + "H", "CH2CCH2","CH3CCH", "H", "", "1.30e-11","+0.00","-01156","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "CH2CCH2","C3H5", "", "", "8.00e-24","+2.00","-01225","1.40e-11","+00.0","-01000","3", /* cf V05 */ + "H", "C3H5", "C2H3", "CH3", "", "4.00e-12","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H5", "CH2CCH2","H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "CH3CCH", "H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "C3H6", "", "", "1.00e-24","+00.0","+00000","2.80e-10","+00.0","+00000","3", /* cf V05 */ + "H", "C3H6", "C3H5", "H2", "", "2.87e-19","+02.5","-01254","0.00e+00","+00.0","+00000","2", + "H", "C3H6", "CH3", "C2H4", "", "2.20e-11","+00.0","-01641","0.00e+00","+00.0","+00000","2", /* M00 */ + "H", "C3H6", "C3H7", "", "", "1.30e-28","+00.0","-00380","9.47e-15","+1.16","-00440","3", /* cf M05 */ + "H", "C3H7", "C3H6", "H2", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H7", "C2H5", "CH3", "", "6.00e-11","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H7", "C3H8", "", "", "2.50e-27","+0.00","-00000","2.50e-10","+0.00","-00000","3", /* cf M05 */ + "H", "C3H8", "C3H7", "H2", "", "2.20e-18","+2.54","-03400","0.00e+00","+00.0","+00000","2", + "H", "C4H", "C4H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H2", "C4H3", "", "", "2.00e-26","+0.00","-00740","1.39e-10","+0.00","-01184","3", /* cf M05 */ + "H", "C4H3", "C4H4", "", "", "8.56e-10","+00.0","-00405","0.00e+00","+00.0","+00000","2", +// "H", "C4H3", "C4H4", "", "", "1.50e-19","-03.0","-00300","8.56e-10","+00.0","-00405","3", /* cf M05 */ + "H", "C4H3", "C4H2", "H2", "", "1.20e-11","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H3", "C2H2", "C2H2", "", "3.30e-12","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H4", "C4H5", "", "", "3.32e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", +// "H", "C4H4", "C4H5", "", "", "8.76e-08","-7.00","-01390","3.32e-12","+0.00","+00000","3", /* cf W04 */ + "H", "C4H5", "prod", "", "", "1.50e-19","-03.0","-00300","1.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H6", "H2", "C4H5", "", "1.05e-13","+0.70","-03019","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H", "C4H6", "prod", "", "", "7.70e-30","+0.00","-00380","8.50e-12","+0.00","-00000","3", /* cf V05 */ + "H", "C4H10", "prod", "H2", "", "3.50e-11","+0.00","-03970","0.00e+00","+0.00","-00000","2", /* cf V05 */ +// "H", "AC6H5", "C4H2", "C2H2", "", "3.16e-05","-01.6","-01117","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "H", "AC6H5", "AC6H6", "", "", "1.82e+28","-16.3","-03526","1.66e-10","+0.00","+00000","3", /* WetF 97 */ + "H", "AC6H6", "AC6H5", "H2", "", "4.15e-10","+0.00","-08057","0.00e+00","+0.00","+00000","2", /* WetF 97 */ + "H2", "CH", "CH3", "", "", "4.70e-26","-01.6","+00000","2.50e-10","-0.08","+00000","3", /* Brownsword 97 */ + "H2", "CH", "3CH2", "H", "", "3.10e-10","+0.00","-01650","0.00e+00","+00.0","+00000","2", + "H2", "1CH2", "CH3", "H", "", "1.20e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H2", "3CH2", "CH3", "H", "", "5.00e-15","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "H2", "CH3", "CH4", "H", "", "1.14e-20","+2.74","-04740","0.00e+00","+00.0","+00000","2", + "H2", "C2", "C2H", "H", "", "1.77e-10","+0.00","-01470","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "H2", "C2H", "C2H2", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "H2", "C2H3", "H", "C2H4", "", "1.57e-20","+2.56","-02529","0.00e+00","+00.0","+00000","2", + "H2", "C2H5", "C2H6", "H", "", "5.11e-24","+03.6","-04253","0.00e+00","+00.0","+00000","2", + "H2", "C3H5", "H", "C3H6", "", "1.80e-19","+2.38","-09557","0.00e+00","+00.0","+00000","2", + "H2", "C3H7", "C3H8", "H", "", "3.00e-21","+2.84","-04600","0.00e+00","+00.0","+00000","2", + "H2", "C4H", "C4H2", "H", "", "9.20e-18","+2.17","-00478","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "H2", "C4H5", "C4H6", "H", "", "6.61e-15","+0.50","-01864","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H2", "AC6H5", "AC6H6", "H", "", "9.48e-20","+2.43","-03159","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "CH", "CH", "C2H2", "", "", "1.99e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH", "CH4", "C2H4", "H", "", "3.96e-08","-1.04","-00036","0.00e+00","+00.0","+00000","2", + "CH", "C2H2", "C3H2", "H", "", "1.59e-09","-0.23","-00016","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "CH", "C2H4", "CH3CCH", "H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H4", "CH2CCH2","H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C2H4", "CH3", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C3H6", "H", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "CH3CCH", "C4H4", "H", "", "4.60e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Butler 81, cf M05 */ + "CH", "C3H8", "prod", "H", "", "1.90e-10","+0.00","+00240","0.00e+00","+00.0","+00000","2", + "CH", "C4H10", "prod", "", "", "4.40e-10","+0.00","+00028","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "1CH2", "1CH2", "C2H2", "H", "H", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "3CH2", "C2H2", "H", "H", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH3", "C2H4", "H", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH4", "3CH2", "CH4", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH4", "CH3", "CH3", "", "5.90e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H", "C2H2", "CH", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H2", "3CH2", "C2H2", "", "8.14e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H2", "C3H3", "H", "", "2.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H3", "C2H2", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H4", "3CH2", "C2H4", "", "2.30e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H4", "C3H6", "", "", "1.50e-18","-3.00","-00300","1.32e-10","+00.0","+00000","3", /* cf M05 */ + "1CH2", "C2H5", "C2H4", "CH3", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H5", "C3H6", "H", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H6", "3CH2", "C2H6", "", "3.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H6", "C2H5", "CH3", "", "1.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H5", "C4H6", "H", "", "3.30e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H5", "C2H4", "C2H3", "", "6.67e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H6", "3CH2", "C3H6", "", "5.00e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "1CH2", "C3H6", "C3H5", "CH3", "", "8.70e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H7", "C2H5", "C2H4", "", "4.29e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H7", "C3H6", "CH3", "", "1.71e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H8", "C2H5", "C2H5", "", "1.60e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "N2", "3CH2", "N2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "3CH2", "C2H2", "H", "H", "1.80e-10","+0.00","-00400","0.00e+00","+00.0","+00000","2", + "3CH2", "3CH2", "C2H2", "H2", "", "2.00e-11","-00.0","-00400","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "3CH2", "CH3", "C2H4", "H", "", "7.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "CH4", "CH3", "CH3", "", "7.13e-12","+0.00","-05052","0.00e+00","+00.0","+00000","2", + "3CH2", "CH4", "C2H6", "", "", "3.50e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H", "CH", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H2", "C3H2", "H2", "", "1.00e-12","-00.0","-03332","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "3CH2", "C2H2", "C3H3", "H", "", "2.00e-11","+0.00","-03330","0.00e+00","+00.0","+00000","2", /* cf W04,V05 */ + "3CH2", "C2H3", "CH3", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H4", "C3H5", "H", "", "5.31e-12","+0.00","-02658","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "3CH2", "C2H5", "CH3", "C2H4", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H6", "C3H8", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H6", "CH3", "C2H5", "", "1.07e-11","+0.00","-03981","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H5", "C4H6", "H", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H6", "C3H5", "CH3", "", "1.20e-12","+0.00","-03116","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H7", "CH3", "C3H6", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H7", "C2H4", "C2H5", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H8", "C4H10", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H8", "C3H7", "CH3", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "3CH2", "C4H2", "C4H", "CH3", "", "2.16e-11","+0.00","-02165","0.00e+00","+00.0","+00000","2", + "3CH2", "C4H6" ,"CH3CCH", "C2H4", "", "6.14e-12","+0.00","-01731","0.00e+00","+0.00","+00000","2", /* Kraus 93 */ + "3CH2", "C4H10", "prod", "", "", "4.30e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H5", "H", "", "8.28e-12","0.099","-05335","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H6", "", "", "1.65e-04","-8.75","-00985","1.17e-10","+0.00","-00000","3", /* Cody 03 */ + "CH3", "C2H", "C3H3", "H", "", "4.00e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H2", "CH3CCH", "H", "", "3.18e-20","+2.42","-06488","0.00e+00","+0.00","+00000","2", /* Diau 94 */ + "CH3", "C2H2", "C3H5", "", "", "3.30e-30","+0.00","-00740","1.00e-12","+0.00","-03900","3", /* cf V05 */ + "CH3", "C2H3", "C2H2", "CH4", "", "3.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H3", "C3H6", "", "", "5.00e-27","+0.00","-00000","1.10e-10","+0.00","+00000","3", /* cf M05 */ + "CH3", "C2H4", "C2H3", "CH4", "", "1.10e-23","+03.7","-04780","0.00e+00","+00.0","+00000","2", + "CH3", "C2H4", "C3H7", "", "", "1.39e-29","+00.0","-00562","3.50e-13","+00.0","-03700","3", /* cf V05 */ + "CH3", "C2H5", "CH4", "C2H4", "", "3.25e-11","-0.50","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H5", "C3H8", "", "", "1.01e+20","-16.1","-01897","8.12e-10","-0.50","+00000","3", + "CH3", "C2H6", "CH4", "C2H5", "", "2.50e-31","+6.00","-03043","0.00e+00","+00.0","+00000","2", +// "CH3", "C3H3", "C4H6", "", "", "3.50e-06","-07.0","-01390","6.80e-11","+00.0","+00130","3", /* cf V05 */ + "CH3", "CH3CCH", "C2H6", "C2H", "", "8.32e-13","+00.0","-04428","0.00e+00","+00.0","+00000","2", + "CH3", "CH2CCH2","C2H5", "C2H2", "", "3.32e-13","+00.0","-04076","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "CH2CCH2","CH4", "", "5.00e-12","-0.32","+00066","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "prod", "", "", "1.28e-30","-0.32","+00066","1.69e-10","-0.32","+00066","3", /* cf W04 */ + "CH3", "C3H6", "CH4", "C3H5", "", "2.66e-13","+00.0","-04440","0.00e+00","+00.0","+00000","2", + "CH3", "C3H6", "prod", "", "", "7.70e-29","+0.00","-00380","1.19e-13","+00.0","-03330","3", /* cf V05 */ + "CH3", "C3H7", "C4H10", "", "", "8.63e+28","-18.5","-02307","3.20e-10","-0.32","+00000","3", + "CH3", "C3H7", "C3H6", "CH4", "", "1.90e-11","-0.32","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C3H8", "C3H7", "CH4", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "CH3", "C4H4", "C4H3", "CH4", "", "6.61e-13","+0.00","-02502","0.00e+00","+00.0","+00000","2", + "CH3", "C4H6", "prod", "", "", "3.30e-30","+0.00","-00740","1.30e-13","+00.0","-02060","3", /* cf V05 */ + "CH3", "C4H10", "prod", "CH4", "", "6.60e-13","-00.0","-04840","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "CH4", "C2", "CH3CCH", "", "", "1.70e-11","+0.00","-02805","0.00e+00","+00.0","+00000","2", /* Baulch 92 (3C2) */ + "CH4", "C2", "CH3", "C2H", "", "5.05e-11","+0.00","-00297","0.00e+00","+00.0","+00000","2", + "CH4", "C2H", "C2H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "CH4", "C2H3", "C2H4", "CH3", "", "2.40e-24","+4.02","-02754","0.00e+00","+00.0","+00000","2", + "CH4", "C2H5", "C2H6", "CH3", "", "1.43e-25","+4.14","-06322","0.00e+00","+00.0","+00000","2", + "CH4", "C3H5", "C3H6", "CH3", "", "6.60e-23","+3.40","-11670","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "CH4", "C3H7", "C3H8", "CH3", "", "4.00e-26","+4.02","-05473","0.00e+00","+00.0","+00000","2", + "CH4", "C4H", "C4H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "CH4", "AC6H5", "AC6H6", "CH3", "", "3.32e-12","+0.00","-04329","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2", "C2H2", "C2H", "C2H", "", "4.30e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Baulch 92 (1C2) */ + "C2", "C2H4", "C2H", "C2H3", "", "3.30e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Baulch 92 (1C2) */ + "C2", "C2H6", "C2H", "C2H5", "", "1.60e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Baulch 92 (1C2) */ + "C2", "C3H8", "C3H7", "C2H", "", "3.30e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Baulch 92 (1C2) */ + "C2", "AC6H6", "soot", "", "", "5.20e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Reisler 80 */ + "C2H", "C2H", "C2H2", "C2", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H2", "C4H2", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C2H", "C2H2", "C4H", "H2", "", "8.60e-18","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* Ralf Kaiser */ + "C2H", "C2H3", "C2H2", "C2H2", "", "1.60e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H4", "C4H4", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", + "C2H", "C2H5", "C3H3", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H5", "C2H2", "C2H4", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H6", "C2H2", "C2H5", "", "5.10e-11","+0.00","-00076","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "CH3CCH", "C4H2", "CH3", "", "1.60e-10","+0.00","+00071","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "CH2CCH2","C2H2", "C3H3", "", "1.30e-10","+0.00","+00103","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "C3H5", "CH2CCH2","C2H2", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H6", "prod", "H", "", "2.00e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H7", "C3H3", "C2H5", "", "2.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H7", "C3H6", "C2H2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H8", "C3H7", "C2H2", "", "9.80e-11","+0.00","-00071","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C2H", "C4H6", "AC6H6", "H", "", "3.30e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H10", "prod", "C2H2", "", "1.20e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "AC6H6", "soot", "H", "", "8.20e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* WandF 97 */ + "C2H2", "C2H3", "C4H4", "H", "", "3.32e-12","+0.00","-02516","0.00e+00","+00.0","+00000","2", + "C2H2", "C2H3", "C4H5", "", "", "8.20e-30","+0.00","-00352","4.16e-19","+1.90","-01058","3", /* cf M05 */ + "C2H2", "C2H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.60e-14","+00.0","-03520","3", /* cf V05 */ + "C2H2", "C3H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.30e-14","+0.00","-03500","3", /* cf V05 */ + "C2H2", "C3H7", "C3H5", "C2H4", "", "1.20e-12","+0.00","-04531","0.00e+00","+00.0","+00000","2", + "C2H2", "C4H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "C2H2", "C4H3", "soot", "", "", "2.00e-16","+0.00","-00000","0.00e+00","+0.00","+00000","2", + "C2H2", "C4H5", "AC6H6", "H", "", "3.50e-09","-1.07","-02417","0.00e+00","+0.00","+00000","2", /* WetF 94 */ + "C2H2", "C4H5", "AC6H6", "H", "", "4.20e-19","+1.80","-00602","0.00e+00","+0.00","+00000","2", /* Weismann 88 */ + "C2H2", "AC6H5", "soot", "", "", "3.72e-13","+0.00","-01561","0.00e+00","+0.00","+00000","2", /* Yu 94 */ + "C2H3", "C2H3", "C4H6", "", "", "5.00e-18","-3.75","-00300","1.40e-10","+00.0","+00000","3", /* cf M05 */ + "C2H3", "C2H3", "C2H2", "C2H4", "", "2.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H4", "C4H6", "H", "", "8.30e-13","+0.00","-03676","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C3H5", "CH3", "", "6.10e-47","+11.2","+03289","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H4", "C2H4", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H2", "C2H6", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "prod", "", "", "1.90e-27","+0.00","+00000","2.50e-11","+00.0","+00000","3", /* cf W04 */ + "C2H3", "C2H6", "C2H4", "C2H5", "", "9.98e-22","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "CH2CCH2","C2H4", "", "4.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "C3H6", "C2H2", "", "8.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "prod", "H", "H", "8.00e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H3", "C3H6", "CH3", "C4H6", "", "1.20e-12","+0.00","-02520","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "C2H4", "C3H5", "", "3.68e-24","+3.50","-02356","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "prod", "H", "", "1.20e-12","+0.00","-03240","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H3", "C3H7", "C2H4", "C3H6", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "C3H8", "C2H2", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","1.60e-11","+00.0","+00000","3", /* cf V05 */ + "C2H3", "C3H8", "C3H7", "C2H4", "", "1.00e-21","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C4H3", "AC6H6", "", "", "4.77e-10","+0.00","-00411","0.00e+00","+0.00","+00000","2", /* Duran 88 */ + "C2H3", "C4H5", "AC6H6", "H2", "", "3.05e-37","+7.07","-01817","0.00e+00","+0.00","+00000","2", /* Westmoreland 89 */ + "C2H3", "C4H6", "prod", "", "", "1.50e-14","-5.84","-02363","2.45e-12","-0.17","-01630","3", /* cf V05 */ + "C2H4", "C2H5", "C2H3", "C2H6", "", "1.05e-21","+3.13","-09063","0.00e+00","+00.0","+00000","2", + "C2H4", "C3H5", "prod", "H", "", "1.00e-14","+0.00","-05776","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H4", "C3H7", "prod", "", "", "7.70e-30","+0.00","-00380","1.80e-13","+00.0","-03670","3", /* cf V05 */ + "C2H4", "C4H", "C4H2", "C2H3", "", "4.60e-11","+0.00","+00025","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H4", "AC6H5", "prod", "H", "", "1.20e-12","+0.00","-02250","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2H5", "C2H5", "C4H10", "", "", "6.59e-06","-6.39","-00301","1.26e-11","+00.0","-00096","3", + "C2H5", "C2H5", "C2H6", "C2H4", "", "2.40e-12","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "C2H5", "CH2CCH2","C2H6", "C3H3", "", "5.25e-13","+0.00","-04579","0.00e+00","+0.00","+00000","2", /* Getty 67 */ + "C2H5", "C3H5", "CH2CCH2","C2H6", "", "1.60e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "C3H6", "C2H4", "", "4.30e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "prod", "", "", "3.50e-07","-07.0","-01390","3.30e-11","+00.0","+00066","3", /* cf V05 */ + "C2H5", "C3H6", "C2H6", "C3H5", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H6", "prod", "", "", "7.70e-30","-00.0","-00380","1.70e-13","+00.0","+03625","3", /* cf V05 */ + "C2H5", "C3H7", "C2H6", "C3H6", "", "2.40e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "C3H8", "C2H4", "", "1.90e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "prod", "", "", "9.70e+28","-18.5","-02307","3.30e-11","+00.0","+00000","3", /* cf V05 */ + "C2H5", "C3H8", "C3H7", "C2H6", "", "1.50e-24","+3.65","-04600","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H5", "C2H5", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H7", "C3H8", "C2H5", "", "4.20e-25","+3.82","-04550","0.00e+00","+00.0","+00000","2", + "C2H6", "C4H", "C4H2", "C2H5", "", "3.50e-11","+0.00","+00003","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C3H3", "AC6H6", "", "", "6.00e-28","+0.00","+01680","1.20e-10","+0.00","+00000","3", /* Moses 00, Morter 94 */ + "C3H3", "C3H5", "prod", "", "", "2.90e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C4H2", "CH3CCH", "C4H", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Alkernade 89 */ + "C3H5", "C3H5", "CH2CCH2","C3H6", "", "1.40e-13","+0.00","+00132","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H5", "prod", "", "", "3.50e-07","-7.00","-01390","1.70e-11","+0.00","+00132","3", /* cf V05 */ + "C3H5", "C3H6", "C2H5", "C4H4", "", "1.00e-14","+0.00","-05776","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "C3H5", "C3H7", "C3H6", "C3H6", "", "2.40e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "CH2CCH2","C3H8", "", "1.20e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","3.40e-11","+0.00","+00066","3", /* cf V05 */ + "C3H5", "C3H8", "C3H7", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C3H5", "C4H10", "C3H6", "prod", "", "7.00e-23","+3.30","-07800","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C3H6", "C3H7", "C3H5", "C3H8", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "C3H8", "C3H6", "", "2.80e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "prod", "", "", "2.90e-21","+0.00","+00000","1.70e-11","+00.0","+00000","3", /* cf V05 */ + "C4H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pad de 1/3 */ + "C4H2s", "", "C4H2", "", "", "1.00e+01","+0.00","+00000","0.00e+00","+00.0","+00000","1", + "C4H2s", "N2", "C4H2", "N2", "", "1.40e-15","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H2", "prod", "H", "H", "3.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H4", "prod", "H", "H", "4.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "CH3", "H", "2.30e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H3", "", "8.70e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "CH3", "H", "4.10e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H3", "", "4.90e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "C2H2", "", "8.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "H", "H", "1.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "soot", "H", "", "9.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "AC6H6", "C2H2", "", "8.80e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "prod", "C2H4", "", "3.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H3", "C4H3", "prod", "", "", "3.50e-07","-7.00","-01390","7.00e-11","+0.00","+00000","3", /* cf V05 */ + "C4H4", "C4H4", "prod", "", "", "7.25e-14","+0.00","-09261","0.00e+00","+00.0","+00000","2", + "AC6H5", "AC6H6", "prod", "", "", "1.59e-12","+0.00","-02168","0.00e+00","+00.0","+00000","2", /* cf W04 */ + + "N4S", "N4S", "N2", "", "", "8.27e-34","+0.00","+00490","0.00e+00","+00.0","+00000","3", + "N4S", "CH", "CN", "H", "", "2.67e-10","-0.09","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "HCN", "H2", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "H2CN", "H", "", "5.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", +/* "N4S", "C2H2", "CH2CN", "", "", "1.70e-14","+0.00","+00000","0.00e+00","+0.00","+00000","2", Sato 74 */ + "N4S", "C2H3", "CH3CN", "", "", "3.08e-12","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H3", "CH2CN", "H", "", "6.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H4", "CH3", "HCN", "", "3.32e-14","+0.00","-00352","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C2H5", "HCN", "CH4", "", "1.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Stief 95 */ + "N4S", "C2H6", "prod", "", "", "0.00e-00","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3CCH", "CHCN", "CH3", "", "1.15e-13","+0.00","-00745","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C3H6", "HCN", "C2H4", "H", "2.49e-13","+0.00","-00830","0.00e+00","+0.00","+00000","2", /* Paraskevopoulos 67 */ + "N4S", "C3H8", "HCN", "C2H6", "H", "3.39e-13","+0.00","-02563","0.00e+00","+0.00","+00000","2", /* Onyzchuk 53 */ + "N4S", "C4H10", "C3H8", "HCN", "H", "2.97e-14","+0.00","-01813","0.00e+00","+0.00","+00000","2", /* Back 54 */ + "N4S", "H2CN", "HCN", "prod", "", "1.00e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "N4S", "CHCN", "NCCN", "H", "", "6.00e-15","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Safrany 68 */ + "N4S", "CH3CN", "HCN", "HCN", "H", "2.28e-15","+0.00","-00813","0.00e+00","+0.00","+00000","2", /* Forst 57 */ + "CN", "H", "HCN", "", "", "2.40e-24","-2.20","-00567","2.99e-09","-0.50","+00000","3", /* Tsang 92 */ + "CN", "H2", "HCN", "H", "", "2.23e-21","+3.31","-00756","0.00e+00","+00.0","+00000","2", + "CN", "CH4", "HCN", "CH3", "", "4.64e-16","+1.53","-00504","0.00e+00","+00.0","+00000","2", /* est, Yang 93 */ + "CN", "CH4", "CH3CN", "H", "", "5.15e-17","+1.53","-00504","0.00e+00","+0.00","+00000","2", /* est, Yang 93 */ + "CN", "C2H2", "HC3N", "H", "", "5.67e-09","-0.55","-00004","0.00e+00","+00.0","+00000","2", + "CN", "C2H6", "HCN", "C2H5", "", "5.91e-12","+0.22","+00058","0.00e+00","+00.0","+00000","2", + "CN", "CH3CCH", "HC3N", "CH3", "", "2.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Sayah 88 */ + "CN", "CH2CCH2","HCN", "C3H3", "", "2.63e-10","+0.00","+00167","0.00e+00","+0.00","+00000","2", /* Butterfield 93 */ + "CN", "C3H6", "prod", "H", "", "1.73e-10","+0.00","+00102","0.00e+00","+0.00","+00000","2", /* Sims 93 */ + "CN", "C3H8", "C3H7", "HCN", "", "2.44e-14","+1.19","+00378","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "C4H2", "HC3N", "C2H", "", "5.26e-09","-0.52","-00019","0.00e+00","+0.00","+00000","2", /* est. Sims 93 */ + "CN", "C4H4", "C4H3", "HCN", "", "1.07e-07","-0.82","-00228","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CN", "NCCN", "", "", "9.44e-23","-2.61","+00000","9.40e-12","+0.00","+00000","3", /* Tsang 92 */ + "CN", "HCN", "NCCN", "H", "", "2.51e-17","+1.71","-00770","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CH3CN", "NCCN", "CH3", "", "6.46e-11","+0.00","-01190","0.00e+00","+0.00","+00000","2", /* Zabarnick 89 */ + "CN", "NCCN", "prod", "", "", "2.19e-21","+2.70","-00325","0.00e+00","+00.0","+00000","2", + "CN", "HC3N", "C4N2", "H", "", "1.70e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Halpern 89 */ + "CN", "C4N2", "NCCN", "C3N", "", "5.40e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Seki 96 */ + "HCN", "H", "H2CN", "", "", "4.40e-24","-2.73","-03855","5.50e-11","+00.0","-02438","3", + "HCN", "CH", "CHCN", "H", "", "5.00e-11","+0.00","+00500","0.00e+00","+0.00","+00000","2", /* Zabarnick 91 */ + "HCN", "C2H", "H", "HC3N", "", "5.26e-12","+0.00","-00770","0.00e+00","+00.0","+00000","2", + "HCN", "H2CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "H", "HCN", "H2", "", "1.40e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "H2CN", "H2CN", "prod", "HCN", "", "1.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Horne 70 */ + "H2CN", "CH3CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "NCCN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "HC3N", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "N2", "CH", "prod", "", "", "3.80e-25","-2.60","+00000","9.65e-11","-0.15","+00000","3", /* Fulle 96 */ + "CHCN", "H2", "CH3CN", "", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Adamson 97 */ + "CH2CN", "CH2CN", "C2H4", "NCCN", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* est, Hoobler 97 */ + "CH3CN", "H", "CH3", "HCN", "", "3.39e-12","+0.00","-03954","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "H", "CH4", "CN", "", "1.66e-13","+0.00","-01505","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "C2H", "HC3N", "CH3", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* Hoobler 97 */ + "C3N", "H2", "HC3N", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "C3N", "CH4", "HC3N", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "C3N", "C2H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "C2H4", "prod", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", + "C3N", "C2H6", "HC3N", "C2H5", "", "3.50e-11","+0.00","+00002","0.00e+00","+00.0","+00000","2", + "C3N", "C3H8", "C3H7", "HC3N", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3N", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "HC3N", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "H", "HCN", "C2H2", "", "1.00e-28","+0.00","-00740","0.55e-12","+00.0","-00500","3", + "HC3N", "C2H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H", "prod", "H", "", "2.90e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H3", "soot", "", "", "1.20e-15","+0.00","-00000","0.00e+00","+0.00","+00000","2", Index: trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006 =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006 (revision 1643) @@ -0,0 +1,388 @@ + "H2", "HV", "H", "H", "", "","","","","","","", /* 1 */ + "CH3", "HV", "1CH2", "H", "", "","","","","","","", /* 2 */ + "CH4", "HV", "1CH2", "H2", "", "","","","","","","", /* 3 */ + "CH4", "HV", "CH", "H2", "H", "","","","","","","", /* 4 */ + "CH4", "HV", "CH3", "H", "", "","","","","","","", /* 5 */ + "C2H2", "HV", "C2H", "H", "", "","","","","","","", /* 6 */ + "C2H2", "HV", "C2", "H2", "", "","","","","","","", /* 7 */ + "C2H4", "HV", "C2H2", "H2", "", "","","","","","","", /* 8 */ + "C2H4", "HV", "C2H2", "H", "H", "","","","","","","", /* 9 */ + "C2H6", "HV", "C2H4", "H2", "", "","","","","","","", /* 10 */ + "C2H6", "HV", "C2H4", "H", "H", "","","","","","","", /* 11 */ + "C2H6", "HV", "C2H2", "H2", "H2","","","","","","","", /* 12 */ + "C2H6", "HV", "CH4", "1CH2", "", "","","","","","","", /* 13 */ + "C2H6", "HV", "CH3", "CH3", "", "","","","","","","", /* 14 */ + "C3H3", "HV", "C3H2", "H", "", "","","","","","","", /* 15 */ + "CH2CCH2","HV", "C3H3", "H", "", "","","","","","","", /* 16 */ + "CH2CCH2","HV", "C3H2", "H2", "", "","","","","","","", /* 17 */ + "CH3CCH", "HV", "C3H3", "H", "", "","","","","","","", /* 18 */ + "CH3CCH", "HV", "C3H2", "H2", "", "","","","","","","", /* 19 */ + "C3H6", "HV", "CH2CCH2","H", "H", "","","","","","","", /* 20 */ + "C3H6", "HV", "CH3CCH", "H", "H", "","","","","","","", /* 21 */ + "C3H6", "HV", "C2H4", "3CH2", "", "","","","","","","", /* 22 */ + "C3H6", "HV", "C2H3", "CH3", "", "","","","","","","", /* 23 */ + "C3H6", "HV", "C2H2", "CH4", "", "","","","","","","", /* 24 */ + "C3H8", "HV", "C3H6", "H2", "", "","","","","","","", /* 25 */ + "C3H8", "HV", "C2H6", "1CH2", "", "","","","","","","", /* 26 */ + "C3H8", "HV", "C2H5", "CH3", "", "","","","","","","", /* 27 */ + "C3H8", "HV", "C2H4", "CH4", "", "","","","","","","", /* 28 */ + "C4H2", "HV", "C4H", "H", "", "","","","","","","", /* 29 */ + "C4H2", "HV", "C2H", "C2H", "", "","","","","","","", /* 30 */ + "C4H2", "HV", "C2H2", "C2", "", "","","","","","","", /* 31 */ + "C4H2", "HV", "C4H2s", "", "", "","","","","","","", /* 32 */ + "C4H4", "HV", "C4H2", "H2", "", "","","","","","","", /* 33 */ + "C4H4", "HV", "C2H2", "C2H2", "", "","","","","","","", /* 34 */ + "C4H6", "HV", "C4H4", "H2", "", "","","","","","","", /* 35 */ + "C4H6", "HV", "C2H4", "C2H2", "", "","","","","","","", /* 36 */ + "C4H6", "HV", "CH3", "C3H3", "", "","","","","","","", /* 37 */ + "C4H10", "HV", "C3H5", "CH3", "H2","","","","","","","", /* 38 */ + "C4H10", "HV", "C2H4", "C2H4", "H2","","","","","","","", /* 39 */ + "C4H10", "HV", "C3H6", "CH4", "", "","","","","","","", /* 40 */ + "C4H10", "HV", "C3H6", "CH3", "H", "","","","","","","", /* 41 */ + "C4H10", "HV", "C2H4", "C2H6", "", "","","","","","","", /* 42 */ + "C4H10", "HV", "C2H2", "C2H6", "H2","","","","","","","", /* 43 */ + "C4H10", "HV", "CH3", "C3H7", "", "","","","","","","", /* 44 */ + "C4H10", "HV", "C2H5", "C2H5", "", "","","","","","","", /* 45 */ + + "AC6H6", "HV", "prod", "CH3", "", "","","","","","","", /* 46 */ + "AC6H6", "HV", "AC6H5", "H", "", "","","","","","","", /* 47 */ + + "N2", "HV", "N4S", "N4S", "", "","","","","","","", /* 48 */ + "HCN", "HV", "H", "CN", "", "","","","","","","", /* 49 */ + "HC3N", "HV", "C2H", "CN", "", "","","","","","","", /* 50 */ + "HC3N", "HV", "H", "C3N", "", "","","","","","","", /* 51 */ + "NCCN", "HV", "CN", "CN", "", "","","","","","","", /* 52 */ + "CH3CN", "HV", "CH3", "CN", "", "","","","","","","", /* 53 */ + "C4N2", "HV", "C3N", "CN", "", "","","","","","","", /* 54 */ + + "N2", "", "N4S", "N4S", "", "0.00e+00","+00.0","+00000","0.00e+00","+00.0","+00000","1", + + "H", "H", "H2", "", "", "2.70e-31","-00.6","+00000","1.00e-11","+00.0","+00000","3", /* Baulch92 */ + "H", "1CH2", "CH", "H2", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H", "3CH2", "H2", "CH", "", "3.54e-11","+0.32","+00000","0.00e+00","+00.0","+00000","2", + "H", "3CH2", "CH3", "", "", "1.70e-25","-01.8","+00000","3.50e-11","+0.32","-00000","3", /* cf V05 */ + "H", "CH3", "CH4", "", "", "6.33e-21","-2.98","-00635","2.63e-08","-0.60","-00189","3", + "H", "CH3", "H2", "3CH2", "", "1.00e-10","+00.0","-07600","0.00e+00","+00.0","+00000","2", + "H", "CH4", "H2", "CH3", "", "2.18e-20","+03.0","-04045","0.00e+00","+00.0","+00000","2", + "H", "C2H", "C2H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C2H2", "C2H3", "", "", "3.30e-30","+00.0","-00740","1.40e-11","+00.0","-01300","3", + "H", "C2H3", "H2", "C2H2", "", "6.86e-11","+00.0","+00023","0.00e+00","+00.0","+00000","2", + "H", "C2H3", "C2H4", "", "", "5.76e-24","-01.3","+00000","1.80e-10","+00.0","-00000","3", /* cf M05 */ + "H", "C2H4", "C2H3", "H2", "", "8.40e-17","+1.93","-06518","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "C2H4", "C2H5", "", "", "1.39e-29","+00.0","-00562","6.60e-15","+1.28","-00650","3", + "H", "C2H5", "CH3", "CH3", "", "1.20e-10","+00.0","-00000","0.00e+00","+00.0","+00000","2", /* Sillesen 93 */ + "H", "C2H5", "H2", "C2H4", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C2H5", "C2H6", "", "", "5.50e-23","-2.00","-01040","1.66e-10","+00.0","+00000","3", + "H", "C2H6", "H2", "C2H5", "", "2.40e-15","+01.5","-03730","0.00e+00","+00.0","+00000","2", + "H", "C3H2", "C3H3", "", "", "1.70e-23","-1.80","-00000","1.00e-10","+0.00","+00000","3", /* cf V05 */ + "H", "C3H3", "CH3CCH", "", "", "9.40e-20","-3.30","-00000","1.00e-10","+0.00","+00000","3", /* cf M05 */ + "H", "C3H3", "CH2CCH2","", "", "1.70e-25","-01.8","+00000","2.50e-10","+0.00","-00000","3", /* cf V05 */ + "H", "CH3CCH", "CH3", "C2H2", "", "8.00e-24","-02.0","-01225","9.63e-12","+00.0","-01560","3", /* cf W04 */ + "H", "CH3CCH", "C3H3", "H2", "", "4.70e-16","+1.74","-03873","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "CH3CCH", "C3H5", "", "", "4.40e-31","+00.0","-00000","6.00e-11","+00.0","-01233","3", /* cf V05 */ + "H", "CH2CCH2","C2H2", "CH3", "", "8.00e-24","-2.00","-01225","9.70e-13","+0.00","-01550","3", /* cf W04 */ + "H", "CH2CCH2","CH3CCH", "H", "", "1.30e-11","+0.00","-01156","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "CH2CCH2","C3H5", "", "", "8.00e-24","+2.00","-01225","1.40e-11","+00.0","-01000","3", /* cf V05 */ + "H", "C3H5", "C2H3", "CH3", "", "4.00e-12","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H5", "CH2CCH2","H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "CH3CCH", "H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "C3H6", "", "", "1.00e-24","+00.0","+00000","2.80e-10","+00.0","+00000","3", /* cf V05 */ + "H", "C3H6", "C3H5", "H2", "", "2.87e-19","+02.5","-01254","0.00e+00","+00.0","+00000","2", + "H", "C3H6", "CH3", "C2H4", "", "2.20e-11","+00.0","-01641","0.00e+00","+00.0","+00000","2", /* M00 */ + "H", "C3H6", "C3H7", "", "", "1.30e-28","+00.0","-00380","9.47e-15","+1.16","-00440","3", /* cf M05 */ + "H", "C3H7", "C3H6", "H2", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H7", "C2H5", "CH3", "", "6.00e-11","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H7", "C3H8", "", "", "2.50e-27","+0.00","-00000","2.50e-10","+0.00","-00000","3", /* cf M05 */ + "H", "C3H8", "C3H7", "H2", "", "2.20e-18","+2.54","-03400","0.00e+00","+00.0","+00000","2", + "H", "C4H", "C4H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H2", "C4H3", "", "", "2.00e-26","+0.00","-00740","1.39e-10","+0.00","-01184","3", /* cf M05 */ + "H", "C4H3", "C4H4", "", "", "8.56e-10","+00.0","-00405","0.00e+00","+00.0","+00000","2", +// "H", "C4H3", "C4H4", "", "", "1.50e-19","-03.0","-00300","8.56e-10","+00.0","-00405","3", /* cf M05 */ + "H", "C4H3", "C4H2", "H2", "", "1.20e-11","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H3", "C2H2", "C2H2", "", "3.30e-12","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H4", "C4H5", "", "", "3.32e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", +// "H", "C4H4", "C4H5", "", "", "8.76e-08","-7.00","-01390","3.32e-12","+0.00","+00000","3", /* cf W04 */ + "H", "C4H5", "prod", "", "", "1.50e-19","-03.0","-00300","1.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H6", "H2", "C4H5", "", "1.05e-13","+0.70","-03019","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H", "C4H6", "prod", "", "", "7.70e-30","+0.00","-00380","8.50e-12","+0.00","-00000","3", /* cf V05 */ + "H", "C4H10", "prod", "H2", "", "3.50e-11","+0.00","-03970","0.00e+00","+0.00","-00000","2", /* cf V05 */ +// "H", "AC6H5", "C4H2", "C2H2", "", "3.16e-05","-01.6","-01117","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "H", "AC6H5", "AC6H6", "", "", "1.82e+28","-16.3","-03526","1.66e-10","+0.00","+00000","3", /* WetF 97 */ + "H", "AC6H6", "AC6H5", "H2", "", "4.15e-10","+0.00","-08057","0.00e+00","+0.00","+00000","2", /* WetF 97 */ + "H2", "CH", "CH3", "", "", "4.70e-26","-01.6","+00000","2.50e-10","-0.08","+00000","3", /* Brownsword 97 */ + "H2", "CH", "3CH2", "H", "", "3.10e-10","+0.00","-01650","0.00e+00","+00.0","+00000","2", + "H2", "1CH2", "CH3", "H", "", "1.20e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H2", "3CH2", "CH3", "H", "", "5.00e-15","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "H2", "CH3", "CH4", "H", "", "1.14e-20","+2.74","-04740","0.00e+00","+00.0","+00000","2", + "H2", "C2", "C2H", "H", "", "1.77e-10","+0.00","-01470","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "H2", "C2H", "C2H2", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "H2", "C2H3", "H", "C2H4", "", "1.57e-20","+2.56","-02529","0.00e+00","+00.0","+00000","2", + "H2", "C2H5", "C2H6", "H", "", "5.11e-24","+03.6","-04253","0.00e+00","+00.0","+00000","2", + "H2", "C3H5", "H", "C3H6", "", "1.80e-19","+2.38","-09557","0.00e+00","+00.0","+00000","2", + "H2", "C3H7", "C3H8", "H", "", "3.00e-21","+2.84","-04600","0.00e+00","+00.0","+00000","2", + "H2", "C4H", "C4H2", "H", "", "9.20e-18","+2.17","-00478","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "H2", "C4H5", "C4H6", "H", "", "6.61e-15","+0.50","-01864","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H2", "AC6H5", "AC6H6", "H", "", "9.48e-20","+2.43","-03159","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "CH", "CH", "C2H2", "", "", "1.99e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH", "CH4", "C2H4", "H", "", "3.96e-08","-1.04","-00036","0.00e+00","+00.0","+00000","2", + "CH", "C2H2", "C3H2", "H", "", "1.59e-09","-0.23","-00016","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "CH", "C2H4", "CH3CCH", "H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H4", "CH2CCH2","H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C2H4", "CH3", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C3H6", "H", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "CH3CCH", "C4H4", "H", "", "4.60e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Butler 81, cf M05 */ + "CH", "C3H8", "prod", "H", "", "1.90e-10","+0.00","+00240","0.00e+00","+00.0","+00000","2", + "CH", "C4H10", "prod", "", "", "4.40e-10","+0.00","+00028","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "1CH2", "1CH2", "C2H2", "H", "H", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "3CH2", "C2H2", "H", "H", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH3", "C2H4", "H", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH4", "3CH2", "CH4", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "CH4", "CH3", "CH3", "", "5.90e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H", "C2H2", "CH", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H2", "3CH2", "C2H2", "", "8.14e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H2", "C3H3", "H", "", "2.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H3", "C2H2", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H4", "3CH2", "C2H4", "", "2.30e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H4", "C3H6", "", "", "1.50e-18","-3.00","-00300","1.32e-10","+00.0","+00000","3", /* cf M05 */ + "1CH2", "C2H5", "C2H4", "CH3", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H5", "C3H6", "H", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H6", "3CH2", "C2H6", "", "3.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C2H6", "C2H5", "CH3", "", "1.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H5", "C4H6", "H", "", "3.30e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H5", "C2H4", "C2H3", "", "6.67e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H6", "3CH2", "C3H6", "", "5.00e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "1CH2", "C3H6", "C3H5", "CH3", "", "8.70e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H7", "C2H5", "C2H4", "", "4.29e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H7", "C3H6", "CH3", "", "1.71e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "C3H8", "C2H5", "C2H5", "", "1.60e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "1CH2", "N2", "3CH2", "N2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "3CH2", "C2H2", "H", "H", "1.80e-10","+0.00","-00400","0.00e+00","+00.0","+00000","2", + "3CH2", "3CH2", "C2H2", "H2", "", "2.00e-11","-00.0","-00400","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "3CH2", "CH3", "C2H4", "H", "", "7.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "CH4", "CH3", "CH3", "", "7.13e-12","+0.00","-05052","0.00e+00","+00.0","+00000","2", + "3CH2", "CH4", "C2H6", "", "", "3.50e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H", "CH", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H2", "C3H2", "H2", "", "1.00e-12","-00.0","-03332","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "3CH2", "C2H2", "C3H3", "H", "", "2.00e-11","+0.00","-03330","0.00e+00","+00.0","+00000","2", /* cf W04,V05 */ + "3CH2", "C2H3", "CH3", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H4", "C3H5", "H", "", "5.31e-12","+0.00","-02658","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "3CH2", "C2H5", "CH3", "C2H4", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H6", "C3H8", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C2H6", "CH3", "C2H5", "", "1.07e-11","+0.00","-03981","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H5", "C4H6", "H", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H6", "C3H5", "CH3", "", "1.20e-12","+0.00","-03116","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H7", "CH3", "C3H6", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H7", "C2H4", "C2H5", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H8", "C4H10", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "3CH2", "C3H8", "C3H7", "CH3", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "3CH2", "C4H2", "C4H", "CH3", "", "2.16e-11","+0.00","-02165","0.00e+00","+00.0","+00000","2", + "3CH2", "C4H6" ,"CH3CCH", "C2H4", "", "6.14e-12","+0.00","-01731","0.00e+00","+0.00","+00000","2", /* Kraus 93 */ + "3CH2", "C4H10", "prod", "", "", "4.30e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H5", "H", "", "8.28e-12","0.099","-05335","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H6", "", "", "1.65e-04","-8.75","-00985","1.17e-10","+0.00","-00000","3", /* Cody 03 */ + "CH3", "C2H", "C3H3", "H", "", "4.00e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H2", "CH3CCH", "H", "", "3.18e-20","+2.42","-06488","0.00e+00","+0.00","+00000","2", /* Diau 94 */ + "CH3", "C2H2", "C3H5", "", "", "3.30e-30","+0.00","-00740","1.00e-12","+0.00","-03900","3", /* cf V05 */ + "CH3", "C2H3", "C2H2", "CH4", "", "3.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H3", "C3H6", "", "", "5.00e-27","+0.00","-00000","1.10e-10","+0.00","+00000","3", /* cf M05 */ + "CH3", "C2H4", "C2H3", "CH4", "", "1.10e-23","+03.7","-04780","0.00e+00","+00.0","+00000","2", + "CH3", "C2H4", "C3H7", "", "", "1.39e-29","+00.0","-00562","3.50e-13","+00.0","-03700","3", /* cf V05 */ + "CH3", "C2H5", "CH4", "C2H4", "", "3.25e-11","-0.50","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H5", "C3H8", "", "", "1.01e+20","-16.1","-01897","8.12e-10","-0.50","+00000","3", + "CH3", "C2H6", "CH4", "C2H5", "", "2.50e-31","+6.00","-03043","0.00e+00","+00.0","+00000","2", +// "CH3", "C3H3", "C4H6", "", "", "3.50e-06","-07.0","-01390","6.80e-11","+00.0","+00130","3", /* cf V05 */ + "CH3", "CH3CCH", "C2H6", "C2H", "", "8.32e-13","+00.0","-04428","0.00e+00","+00.0","+00000","2", + "CH3", "CH2CCH2","C2H5", "C2H2", "", "3.32e-13","+00.0","-04076","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "CH2CCH2","CH4", "", "5.00e-12","-0.32","+00066","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "prod", "", "", "1.28e-30","-0.32","+00066","1.69e-10","-0.32","+00066","3", /* cf W04 */ + "CH3", "C3H6", "CH4", "C3H5", "", "2.66e-13","+00.0","-04440","0.00e+00","+00.0","+00000","2", + "CH3", "C3H6", "prod", "", "", "7.70e-29","+0.00","-00380","1.19e-13","+00.0","-03330","3", /* cf V05 */ + "CH3", "C3H7", "C4H10", "", "", "8.63e+28","-18.5","-02307","3.20e-10","-0.32","+00000","3", + "CH3", "C3H7", "C3H6", "CH4", "", "1.90e-11","-0.32","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C3H8", "C3H7", "CH4", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "CH3", "C4H4", "C4H3", "CH4", "", "6.61e-13","+0.00","-02502","0.00e+00","+00.0","+00000","2", + "CH3", "C4H6", "prod", "", "", "3.30e-30","+0.00","-00740","1.30e-13","+00.0","-02060","3", /* cf V05 */ + "CH3", "C4H10", "prod", "CH4", "", "6.60e-13","-00.0","-04840","0.00e+00","+00.0","+00000","2", /* cf V05 */ +// "CH4", "C2", "CH3CCH", "", "", "1.70e-11","+0.00","-02805","0.00e+00","+00.0","+00000","2", /* Baulch 92 (3C2) */ + "CH4", "C2", "CH3", "C2H", "", "9.83e-11","-0.42","-00013","0.00e+00","+00.0","+00000","2", /* Canosa 06 (1C2) */ + "CH4", "C2H", "C2H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "CH4", "C2H3", "C2H4", "CH3", "", "2.40e-24","+4.02","-02754","0.00e+00","+00.0","+00000","2", + "CH4", "C2H5", "C2H6", "CH3", "", "1.43e-25","+4.14","-06322","0.00e+00","+00.0","+00000","2", + "CH4", "C3H5", "C3H6", "CH3", "", "6.60e-23","+3.40","-11670","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "CH4", "C3H7", "C3H8", "CH3", "", "4.00e-26","+4.02","-05473","0.00e+00","+00.0","+00000","2", + "CH4", "C4H", "C4H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "CH4", "AC6H5", "AC6H6", "CH3", "", "3.32e-12","+0.00","-04329","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2", "C2H2", "C4H", "H", "", "1.92e-07","-1.14","-00077","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2) + produits: Nadia B. */ + "C2", "C2H4", "C4H3", "H", "", "5.10e-08","-0.93","-00058","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2) + produits: Nadia B. */ + "C2", "C2H6", "C2H", "C2H5", "", "2.77e-08","-0.94","-00044","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2); Produits ? */ + "C2", "C3H8", "C3H7", "C2H", "", "3.89e-08","-1.31","-00094","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2); Produits ? */ + "C2", "AC6H6", "soot", "", "", "5.20e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Reisler 80 */ + "C2H", "C2H", "C2H2", "C2", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H2", "C4H2", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C2H2", "C4H", "H2", "", "8.60e-18","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* Ralf Kaiser */ + "C2H", "C2H3", "C2H2", "C2H2", "", "1.60e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H4", "C4H4", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C2H5", "C3H3", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H5", "C2H2", "C2H4", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H6", "C2H2", "C2H5", "", "5.10e-11","+0.00","-00076","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "CH3CCH", "C4H2", "CH3", "", "1.60e-10","+0.00","+00071","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "CH2CCH2","C2H2", "C3H3", "", "1.30e-10","+0.00","+00103","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "C3H5", "CH2CCH2","C2H2", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H6", "prod", "H", "", "2.00e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C3H7", "C3H3", "C2H5", "", "2.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H7", "C3H6", "C2H2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H8", "C3H7", "C2H2", "", "9.80e-11","+0.00","-00071","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C2H", "C4H6", "AC6H6", "H", "", "3.30e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H10", "prod", "C2H2", "", "1.20e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "AC6H6", "soot", "H", "", "8.20e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* WandF 97 */ + "C2H2", "C2H3", "C4H4", "H", "", "3.32e-12","+0.00","-02516","0.00e+00","+00.0","+00000","2", + "C2H2", "C2H3", "C4H5", "", "", "8.20e-30","+0.00","-00352","4.16e-19","+1.90","-01058","3", /* cf M05 */ + "C2H2", "C2H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.60e-14","+00.0","-03520","3", /* cf V05 */ + "C2H2", "C3H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.30e-14","+0.00","-03500","3", /* cf V05 */ + "C2H2", "C3H7", "C3H5", "C2H4", "", "1.20e-12","+0.00","-04531","0.00e+00","+00.0","+00000","2", + "C2H2", "C4H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "C2H2", "C4H3", "soot", "", "", "2.00e-16","+0.00","-00000","0.00e+00","+0.00","+00000","2", + "C2H2", "C4H5", "AC6H6", "H", "", "3.50e-09","-1.07","-02417","0.00e+00","+0.00","+00000","2", /* WetF 94 */ + "C2H2", "C4H5", "AC6H6", "H", "", "4.20e-19","+1.80","-00602","0.00e+00","+0.00","+00000","2", /* Weismann 88 */ + "C2H2", "AC6H5", "soot", "", "", "3.72e-13","+0.00","-01561","0.00e+00","+0.00","+00000","2", /* Yu 94 */ + "C2H3", "C2H3", "C4H6", "", "", "5.00e-18","-3.75","-00300","1.40e-10","+00.0","+00000","3", /* cf M05 */ + "C2H3", "C2H3", "C2H2", "C2H4", "", "2.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H4", "C4H6", "H", "", "8.30e-13","+0.00","-03676","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C3H5", "CH3", "", "6.10e-47","+11.2","+03289","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H4", "C2H4", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H2", "C2H6", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "prod", "", "", "1.90e-27","+0.00","+00000","2.50e-11","+00.0","+00000","3", /* cf W04 */ + "C2H3", "C2H6", "C2H4", "C2H5", "", "9.98e-22","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "CH2CCH2","C2H4", "", "4.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "C3H6", "C2H2", "", "8.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "prod", "H", "H", "8.00e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H3", "C3H6", "CH3", "C4H6", "", "1.20e-12","+0.00","-02520","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "C2H4", "C3H5", "", "3.68e-24","+3.50","-02356","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "prod", "H", "", "1.20e-12","+0.00","-03240","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H3", "C3H7", "C2H4", "C3H6", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "C3H8", "C2H2", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","1.60e-11","+00.0","+00000","3", /* cf V05 */ + "C2H3", "C3H8", "C3H7", "C2H4", "", "1.00e-21","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C4H3", "AC6H6", "", "", "4.77e-10","+0.00","-00411","0.00e+00","+0.00","+00000","2", /* Duran 88 */ + "C2H3", "C4H5", "AC6H6", "H2", "", "3.05e-37","+7.07","-01817","0.00e+00","+0.00","+00000","2", /* Westmoreland 89 */ + "C2H3", "C4H6", "prod", "", "", "1.50e-14","-5.84","-02363","2.45e-12","-0.17","-01630","3", /* cf V05 */ + "C2H4", "C2H5", "C2H3", "C2H6", "", "1.05e-21","+3.13","-09063","0.00e+00","+00.0","+00000","2", + "C2H4", "C3H5", "prod", "H", "", "1.00e-14","+0.00","-05776","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H4", "C3H7", "prod", "", "", "7.70e-30","+0.00","-00380","1.80e-13","+00.0","-03670","3", /* cf V05 */ + "C2H4", "C4H", "C4H2", "C2H3", "", "4.60e-11","+0.00","+00025","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H4", "AC6H5", "prod", "H", "", "1.20e-12","+0.00","-02250","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2H5", "C2H5", "C4H10", "", "", "6.59e-06","-6.39","-00301","1.26e-11","+00.0","-00096","3", + "C2H5", "C2H5", "C2H6", "C2H4", "", "2.40e-12","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "C2H5", "CH2CCH2","C2H6", "C3H3", "", "5.25e-13","+0.00","-04579","0.00e+00","+0.00","+00000","2", /* Getty 67 */ + "C2H5", "C3H5", "CH2CCH2","C2H6", "", "1.60e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "C3H6", "C2H4", "", "4.30e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "prod", "", "", "3.50e-07","-07.0","-01390","3.30e-11","+00.0","+00066","3", /* cf V05 */ + "C2H5", "C3H6", "C2H6", "C3H5", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H6", "prod", "", "", "7.70e-30","-00.0","-00380","1.70e-13","+00.0","+03625","3", /* cf V05 */ + "C2H5", "C3H7", "C2H6", "C3H6", "", "2.40e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "C3H8", "C2H4", "", "1.90e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "prod", "", "", "9.70e+28","-18.5","-02307","3.30e-11","+00.0","+00000","3", /* cf V05 */ + "C2H5", "C3H8", "C3H7", "C2H6", "", "1.50e-24","+3.65","-04600","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H5", "C2H5", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H7", "C3H8", "C2H5", "", "4.20e-25","+3.82","-04550","0.00e+00","+00.0","+00000","2", + "C2H6", "C4H", "C4H2", "C2H5", "", "3.50e-11","+0.00","+00003","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C3H3", "AC6H6", "", "", "6.00e-28","+0.00","+01680","1.20e-10","+0.00","+00000","3", /* Moses 00, Morter 94 */ + "C3H3", "C3H5", "prod", "", "", "2.90e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C4H2", "CH3CCH", "C4H", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Alkernade 89 */ + "C3H5", "C3H5", "CH2CCH2","C3H6", "", "1.40e-13","+0.00","+00132","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H5", "prod", "", "", "3.50e-07","-7.00","-01390","1.70e-11","+0.00","+00132","3", /* cf V05 */ + "C3H5", "C3H6", "C2H5", "C4H4", "", "1.00e-14","+0.00","-05776","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "C3H5", "C3H7", "C3H6", "C3H6", "", "2.40e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "CH2CCH2","C3H8", "", "1.20e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","3.40e-11","+0.00","+00066","3", /* cf V05 */ + "C3H5", "C3H8", "C3H7", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C3H5", "C4H10", "C3H6", "prod", "", "7.00e-23","+3.30","-07800","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C3H6", "C3H7", "C3H5", "C3H8", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "C3H8", "C3H6", "", "2.80e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "prod", "", "", "2.90e-21","+0.00","+00000","1.70e-11","+00.0","+00000","3", /* cf V05 */ + "C4H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pad de 1/3 */ + "C4H2s", "", "C4H2", "", "", "1.00e+01","+0.00","+00000","0.00e+00","+00.0","+00000","1", + "C4H2s", "N2", "C4H2", "N2", "", "1.40e-15","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H2", "prod", "H", "H", "3.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H4", "prod", "H", "H", "4.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "CH3", "H", "2.30e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H3", "", "8.70e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "CH3", "H", "4.10e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H3", "", "4.90e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "C2H2", "", "8.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "H", "H", "1.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "soot", "H", "", "9.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "AC6H6", "C2H2", "", "8.80e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "prod", "C2H4", "", "3.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H3", "C4H3", "prod", "", "", "3.50e-07","-7.00","-01390","7.00e-11","+0.00","+00000","3", /* cf V05 */ + "C4H4", "C4H4", "prod", "", "", "7.25e-14","+0.00","-09261","0.00e+00","+00.0","+00000","2", + "AC6H5", "AC6H6", "prod", "", "", "1.59e-12","+0.00","-02168","0.00e+00","+00.0","+00000","2", /* cf W04 */ + + "N4S", "N4S", "N2", "", "", "8.27e-34","+0.00","+00490","0.00e+00","+00.0","+00000","3", + "N4S", "CH", "CN", "H", "", "2.67e-10","-0.09","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "HCN", "H2", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "H2CN", "H", "", "5.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", +/* "N4S", "C2H2", "CH2CN", "", "", "1.70e-14","+0.00","+00000","0.00e+00","+0.00","+00000","2", Sato 74 */ + "N4S", "C2H3", "CH3CN", "", "", "3.08e-12","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H3", "CH2CN", "H", "", "6.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H4", "CH3", "HCN", "", "3.32e-14","+0.00","-00352","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C2H5", "HCN", "CH4", "", "1.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Stief 95 */ + "N4S", "C2H6", "prod", "", "", "0.00e-00","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3CCH", "CHCN", "CH3", "", "1.15e-13","+0.00","-00745","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C3H6", "HCN", "C2H4", "H", "2.49e-13","+0.00","-00830","0.00e+00","+0.00","+00000","2", /* Paraskevopoulos 67 */ + "N4S", "C3H8", "HCN", "C2H6", "H", "3.39e-13","+0.00","-02563","0.00e+00","+0.00","+00000","2", /* Onyzchuk 53 */ + "N4S", "C4H10", "C3H8", "HCN", "H", "2.97e-14","+0.00","-01813","0.00e+00","+0.00","+00000","2", /* Back 54 */ + "N4S", "H2CN", "HCN", "prod", "", "1.00e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "N4S", "CHCN", "NCCN", "H", "", "6.00e-15","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Safrany 68 */ + "N4S", "CH3CN", "HCN", "HCN", "H", "2.28e-15","+0.00","-00813","0.00e+00","+0.00","+00000","2", /* Forst 57 */ + "CN", "H", "HCN", "", "", "2.40e-24","-2.20","-00567","2.99e-09","-0.50","+00000","3", /* Tsang 92 */ + "CN", "H2", "HCN", "H", "", "2.23e-21","+3.31","-00756","0.00e+00","+00.0","+00000","2", + "CN", "CH4", "HCN", "CH3", "", "4.64e-16","+1.53","-00504","0.00e+00","+00.0","+00000","2", /* est, Yang 93 */ + "CN", "CH4", "CH3CN", "H", "", "5.15e-17","+1.53","-00504","0.00e+00","+0.00","+00000","2", /* est, Yang 93 */ + "CN", "C2H2", "HC3N", "H", "", "5.67e-09","-0.55","-00004","0.00e+00","+00.0","+00000","2", + "CN", "C2H6", "HCN", "C2H5", "", "5.91e-12","+0.22","+00058","0.00e+00","+00.0","+00000","2", + "CN", "CH3CCH", "HC3N", "CH3", "", "2.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Sayah 88 */ + "CN", "CH2CCH2","HCN", "C3H3", "", "2.63e-10","+0.00","+00167","0.00e+00","+0.00","+00000","2", /* Butterfield 93 */ + "CN", "C3H6", "prod", "H", "", "1.73e-10","+0.00","+00102","0.00e+00","+0.00","+00000","2", /* Sims 93 */ + "CN", "C3H8", "C3H7", "HCN", "", "2.44e-14","+1.19","+00378","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "C4H2", "HC3N", "C2H", "", "5.26e-09","-0.52","-00019","0.00e+00","+0.00","+00000","2", /* est. Sims 93 */ + "CN", "C4H4", "C4H3", "HCN", "", "1.07e-07","-0.82","-00228","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CN", "NCCN", "", "", "9.44e-23","-2.61","+00000","9.40e-12","+0.00","+00000","3", /* Tsang 92 */ + "CN", "HCN", "NCCN", "H", "", "2.51e-17","+1.71","-00770","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CH3CN", "NCCN", "CH3", "", "6.46e-11","+0.00","-01190","0.00e+00","+0.00","+00000","2", /* Zabarnick 89 */ + "CN", "NCCN", "prod", "", "", "2.19e-21","+2.70","-00325","0.00e+00","+00.0","+00000","2", + "CN", "HC3N", "C4N2", "H", "", "1.70e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Halpern 89 */ + "CN", "C4N2", "NCCN", "C3N", "", "5.40e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Seki 96 */ + "HCN", "H", "H2CN", "", "", "4.40e-24","-2.73","-03855","5.50e-11","+00.0","-02438","3", + "HCN", "CH", "CHCN", "H", "", "5.00e-11","+0.00","+00500","0.00e+00","+0.00","+00000","2", /* Zabarnick 91 */ + "HCN", "C2H", "H", "HC3N", "", "5.26e-12","+0.00","-00770","0.00e+00","+00.0","+00000","2", + "HCN", "AC6H5", "soot", "", "", "3.72e-13","+0.00","-01561","0.00e+00","+0.00","+00000","2", + "HCN", "H2CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "H", "HCN", "H2", "", "1.40e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "H2CN", "H2CN", "prod", "HCN", "", "1.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Horne 70 */ + "H2CN", "CH3CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "NCCN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "HC3N", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "N2", "CH", "prod", "", "", "3.80e-25","-2.60","+00000","9.65e-11","-0.15","+00000","3", /* Fulle 96 */ + "CHCN", "H2", "CH3CN", "", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Adamson 97 */ + "CH2CN", "CH2CN", "C2H4", "NCCN", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* est, Hoobler 97 */ + "CH3CN", "H", "CH3", "HCN", "", "3.39e-12","+0.00","-03954","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "H", "CH4", "CN", "", "1.66e-13","+0.00","-01505","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "C2H", "HC3N", "CH3", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* Hoobler 97 */ + "C3N", "H2", "HC3N", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "C3N", "CH4", "HC3N", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "C3N", "C2H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "C2H4", "prod", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", + "C3N", "C2H6", "HC3N", "C2H5", "", "3.50e-11","+0.00","+00002","0.00e+00","+00.0","+00000","2", + "C3N", "C3H8", "C3H7", "HC3N", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3N", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "HC3N", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "H", "HCN", "C2H2", "", "1.00e-28","+0.00","-00740","0.55e-12","+00.0","-00500","3", + "HC3N", "C2H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H", "prod", "H", "", "2.90e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H3", "soot", "", "", "1.20e-15","+0.00","-00000","0.00e+00","+0.00","+00000","2", Index: trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006_bis =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006_bis (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/chimie_simpnit_051006_bis (revision 1643) @@ -0,0 +1,388 @@ + "H2", "HV", "H", "H", "", "","","","","","","", /* 1 */ + "CH3", "HV", "CH2s", "H", "", "","","","","","","", /* 2 */ + "CH4", "HV", "CH2s", "H2", "", "","","","","","","", /* 3 */ + "CH4", "HV", "CH", "H2", "H", "","","","","","","", /* 4 */ + "CH4", "HV", "CH3", "H", "", "","","","","","","", /* 5 */ + "C2H2", "HV", "C2H", "H", "", "","","","","","","", /* 6 */ + "C2H2", "HV", "C2", "H2", "", "","","","","","","", /* 7 */ + "C2H4", "HV", "C2H2", "H2", "", "","","","","","","", /* 8 */ + "C2H4", "HV", "C2H2", "H", "H", "","","","","","","", /* 9 */ + "C2H6", "HV", "C2H4", "H2", "", "","","","","","","", /* 10 */ + "C2H6", "HV", "C2H4", "H", "H", "","","","","","","", /* 11 */ + "C2H6", "HV", "C2H2", "H2", "H2","","","","","","","", /* 12 */ + "C2H6", "HV", "CH4", "CH2s", "", "","","","","","","", /* 13 */ + "C2H6", "HV", "CH3", "CH3", "", "","","","","","","", /* 14 */ + "C3H3", "HV", "C3H2", "H", "", "","","","","","","", /* 15 */ + "CH2CCH2","HV", "C3H3", "H", "", "","","","","","","", /* 16 */ + "CH2CCH2","HV", "C3H2", "H2", "", "","","","","","","", /* 17 */ + "CH3CCH", "HV", "C3H3", "H", "", "","","","","","","", /* 18 */ + "CH3CCH", "HV", "C3H2", "H2", "", "","","","","","","", /* 19 */ + "C3H6", "HV", "CH2CCH2","H", "H", "","","","","","","", /* 20 */ + "C3H6", "HV", "CH3CCH", "H", "H", "","","","","","","", /* 21 */ + "C3H6", "HV", "C2H4", "CH2", "", "","","","","","","", /* 22 */ + "C3H6", "HV", "C2H3", "CH3", "", "","","","","","","", /* 23 */ + "C3H6", "HV", "C2H2", "CH4", "", "","","","","","","", /* 24 */ + "C3H8", "HV", "C3H6", "H2", "", "","","","","","","", /* 25 */ + "C3H8", "HV", "C2H6", "CH2s", "", "","","","","","","", /* 26 */ + "C3H8", "HV", "C2H5", "CH3", "", "","","","","","","", /* 27 */ + "C3H8", "HV", "C2H4", "CH4", "", "","","","","","","", /* 28 */ + "C4H2", "HV", "C4H", "H", "", "","","","","","","", /* 29 */ + "C4H2", "HV", "C2H", "C2H", "", "","","","","","","", /* 30 */ + "C4H2", "HV", "C2H2", "C2", "", "","","","","","","", /* 31 */ + "C4H2", "HV", "C4H2s", "", "", "","","","","","","", /* 32 */ + "C4H4", "HV", "C4H2", "H2", "", "","","","","","","", /* 33 */ + "C4H4", "HV", "C2H2", "C2H2", "", "","","","","","","", /* 34 */ + "C4H6", "HV", "C4H4", "H2", "", "","","","","","","", /* 35 */ + "C4H6", "HV", "C2H4", "C2H2", "", "","","","","","","", /* 36 */ + "C4H6", "HV", "CH3", "C3H3", "", "","","","","","","", /* 37 */ + "C4H10", "HV", "C3H5", "CH3", "H2","","","","","","","", /* 38 */ + "C4H10", "HV", "C2H4", "C2H4", "H2","","","","","","","", /* 39 */ + "C4H10", "HV", "C3H6", "CH4", "", "","","","","","","", /* 40 */ + "C4H10", "HV", "C3H6", "CH3", "H", "","","","","","","", /* 41 */ + "C4H10", "HV", "C2H4", "C2H6", "", "","","","","","","", /* 42 */ + "C4H10", "HV", "C2H2", "C2H6", "H2","","","","","","","", /* 43 */ + "C4H10", "HV", "CH3", "C3H7", "", "","","","","","","", /* 44 */ + "C4H10", "HV", "C2H5", "C2H5", "", "","","","","","","", /* 45 */ + + "AC6H6", "HV", "prod", "CH3", "", "","","","","","","", /* 46 */ + "AC6H6", "HV", "AC6H5", "H", "", "","","","","","","", /* 47 */ + + "N2", "HV", "N4S", "N4S", "", "","","","","","","", /* 48 */ + "HCN", "HV", "H", "CN", "", "","","","","","","", /* 49 */ + "HC3N", "HV", "C2H", "CN", "", "","","","","","","", /* 50 */ + "HC3N", "HV", "H", "C3N", "", "","","","","","","", /* 51 */ + "NCCN", "HV", "CN", "CN", "", "","","","","","","", /* 52 */ + "CH3CN", "HV", "CH3", "CN", "", "","","","","","","", /* 53 */ + "C4N2", "HV", "C3N", "CN", "", "","","","","","","", /* 54 */ + + "N2", "", "N4S", "N4S", "", "0.00e+00","+00.0","+00000","0.00e+00","+00.0","+00000","1", + + "H", "H", "H2", "", "", "2.70e-31","-00.6","+00000","1.00e-11","+00.0","+00000","3", /* Baulch92 */ + "H", "CH2s", "CH", "H2", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H", "CH2", "H2", "CH", "", "3.54e-11","+0.32","+00000","0.00e+00","+00.0","+00000","2", + "H", "CH2", "CH3", "", "", "1.70e-25","-01.8","+00000","3.50e-11","+0.32","-00000","3", /* cf V05 */ + "H", "CH3", "CH4", "", "", "6.33e-21","-2.98","-00635","2.63e-08","-0.60","-00189","3", + "H", "CH3", "H2", "CH2", "", "1.00e-10","+00.0","-07600","0.00e+00","+00.0","+00000","2", + "H", "CH4", "H2", "CH3", "", "2.18e-20","+03.0","-04045","0.00e+00","+00.0","+00000","2", + "H", "C2H", "C2H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C2H2", "C2H3", "", "", "3.30e-30","+00.0","-00740","1.40e-11","+00.0","-01300","3", + "H", "C2H3", "H2", "C2H2", "", "6.86e-11","+00.0","+00023","0.00e+00","+00.0","+00000","2", + "H", "C2H3", "C2H4", "", "", "5.76e-24","-01.3","+00000","1.80e-10","+00.0","-00000","3", /* cf M05 */ + "H", "C2H4", "C2H3", "H2", "", "8.40e-17","+1.93","-06518","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "C2H4", "C2H5", "", "", "1.39e-29","+00.0","-00562","6.60e-15","+1.28","-00650","3", + "H", "C2H5", "CH3", "CH3", "", "1.20e-10","+00.0","-00000","0.00e+00","+00.0","+00000","2", /* Sillesen 93 */ + "H", "C2H5", "H2", "C2H4", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C2H5", "C2H6", "", "", "5.50e-23","-2.00","-01040","1.66e-10","+00.0","+00000","3", + "H", "C2H6", "H2", "C2H5", "", "2.40e-15","+01.5","-03730","0.00e+00","+00.0","+00000","2", + "H", "C3H2", "C3H3", "", "", "1.70e-23","-1.80","-00000","1.00e-10","+0.00","+00000","3", /* cf V05 */ + "H", "C3H3", "CH3CCH", "", "", "9.40e-20","-3.30","-00000","1.00e-10","+0.00","+00000","3", /* cf M05 */ + "H", "C3H3", "CH2CCH2","", "", "1.70e-25","-01.8","+00000","2.50e-10","+0.00","-00000","3", /* cf V05 */ + "H", "CH3CCH", "CH3", "C2H2", "", "8.00e-24","-02.0","-01225","9.63e-12","+00.0","-01560","3", /* cf W04 */ + "H", "CH3CCH", "C3H3", "H2", "", "4.70e-16","+1.74","-03873","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "CH3CCH", "C3H5", "", "", "4.40e-31","+00.0","-00000","6.00e-11","+00.0","-01233","3", /* cf V05 */ + "H", "CH2CCH2","C2H2", "CH3", "", "8.00e-24","-2.00","-01225","9.70e-13","+0.00","-01550","3", /* cf W04 */ + "H", "CH2CCH2","CH3CCH", "H", "", "1.30e-11","+0.00","-01156","0.00e+00","+0.00","-00000","2", /* cf V05 */ + "H", "CH2CCH2","C3H5", "", "", "8.00e-24","+2.00","-01225","1.40e-11","+00.0","-01000","3", /* cf V05 */ + "H", "C3H5", "C2H3", "CH3", "", "4.00e-12","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H5", "CH2CCH2","H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "CH3CCH", "H2", "", "1.40e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H5", "C3H6", "", "", "1.00e-24","+00.0","+00000","2.80e-10","+00.0","+00000","3", /* cf V05 */ + "H", "C3H6", "C3H5", "H2", "", "2.87e-19","+02.5","-01254","0.00e+00","+00.0","+00000","2", + "H", "C3H6", "CH3", "C2H4", "", "2.20e-11","+00.0","-01641","0.00e+00","+00.0","+00000","2", /* M00 */ + "H", "C3H6", "C3H7", "", "", "1.30e-28","+00.0","-00380","9.47e-15","+1.16","-00440","3", /* cf M05 */ + "H", "C3H7", "C3H6", "H2", "", "3.00e-12","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "H", "C3H7", "C2H5", "CH3", "", "6.00e-11","+0.00","-00000","0.00e+00","+0.00","-00000","2", /* cf M05 */ + "H", "C3H7", "C3H8", "", "", "2.50e-27","+0.00","-00000","2.50e-10","+0.00","-00000","3", /* cf M05 */ + "H", "C3H8", "C3H7", "H2", "", "2.20e-18","+2.54","-03400","0.00e+00","+00.0","+00000","2", + "H", "C4H", "C4H2", "", "", "1.26e-18","-03.1","-00721","3.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H2", "C4H3", "", "", "2.00e-26","+0.00","-00740","1.39e-10","+0.00","-01184","3", /* cf M05 */ + "H", "C4H3", "C4H4", "", "", "8.56e-10","+00.0","-00405","0.00e+00","+00.0","+00000","2", +// "H", "C4H3", "C4H4", "", "", "1.50e-19","-03.0","-00300","8.56e-10","+00.0","-00405","3", /* cf M05 */ + "H", "C4H3", "C4H2", "H2", "", "1.20e-11","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H3", "C2H2", "C2H2", "", "3.30e-12","+00.0","-00000","0.00e+00","+00.0","+00000","2", + "H", "C4H4", "C4H5", "", "", "3.32e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", +// "H", "C4H4", "C4H5", "", "", "8.76e-08","-7.00","-01390","3.32e-12","+0.00","+00000","3", /* cf W04 */ + "H", "C4H5", "prod", "", "", "1.50e-19","-03.0","-00300","1.00e-10","+00.0","+00000","3", /* cf M05 */ + "H", "C4H6", "H2", "C4H5", "", "1.05e-13","+0.70","-03019","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H", "C4H6", "prod", "", "", "7.70e-30","+0.00","-00380","8.50e-12","+0.00","-00000","3", /* cf V05 */ + "H", "C4H10", "prod", "H2", "", "3.50e-11","+0.00","-03970","0.00e+00","+0.00","-00000","2", /* cf V05 */ +// "H", "AC6H5", "C4H2", "C2H2", "", "3.16e-05","-01.6","-01117","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "H", "AC6H5", "AC6H6", "", "", "1.82e+28","-16.3","-03526","1.66e-10","+0.00","+00000","3", /* WetF 97 */ + "H", "AC6H6", "AC6H5", "H2", "", "4.15e-10","+0.00","-08057","0.00e+00","+0.00","+00000","2", /* WetF 97 */ + "H2", "CH", "CH3", "", "", "4.70e-26","-01.6","+00000","2.50e-10","-0.08","+00000","3", /* Brownsword 97 */ + "H2", "CH", "CH2", "H", "", "3.10e-10","+0.00","-01650","0.00e+00","+00.0","+00000","2", + "H2", "CH2s", "CH3", "H", "", "1.20e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "H2", "CH2", "CH3", "H", "", "5.00e-15","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "H2", "CH3", "CH4", "H", "", "1.14e-20","+2.74","-04740","0.00e+00","+00.0","+00000","2", + "H2", "C2", "C2H", "H", "", "1.77e-10","+0.00","-01470","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "H2", "C2H", "C2H2", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "H2", "C2H3", "H", "C2H4", "", "1.57e-20","+2.56","-02529","0.00e+00","+00.0","+00000","2", + "H2", "C2H5", "C2H6", "H", "", "5.11e-24","+03.6","-04253","0.00e+00","+00.0","+00000","2", + "H2", "C3H5", "H", "C3H6", "", "1.80e-19","+2.38","-09557","0.00e+00","+00.0","+00000","2", + "H2", "C3H7", "C3H8", "H", "", "3.00e-21","+2.84","-04600","0.00e+00","+00.0","+00000","2", + "H2", "C4H", "C4H2", "H", "", "9.20e-18","+2.17","-00478","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "H2", "C4H5", "C4H6", "H", "", "6.61e-15","+0.50","-01864","0.00e+00","+0.00","+00000","2", /* Weisman 88 */ + "H2", "AC6H5", "AC6H6", "H", "", "9.48e-20","+2.43","-03159","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "CH", "CH", "C2H2", "", "", "1.99e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH", "CH4", "C2H4", "H", "", "3.96e-08","-1.04","-00036","0.00e+00","+00.0","+00000","2", + "CH", "C2H2", "C3H2", "H", "", "1.59e-09","-0.23","-00016","0.00e+00","+00.0","+00000","2", /* cf V05,W04,M05 */ + "CH", "C2H4", "CH3CCH", "H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H4", "CH2CCH2","H", "", "3.90e-09","-0.55","-00029","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C2H4", "CH3", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "C2H6", "C3H6", "H", "", "1.90e-08","-0.86","-00053","0.00e+00","+00.0","+00000","2", /* cf V05,W04 */ + "CH", "CH3CCH", "C4H4", "H", "", "4.60e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Butler 81, cf M05 */ + "CH", "C3H8", "prod", "H", "", "1.90e-10","+0.00","+00240","0.00e+00","+00.0","+00000","2", + "CH", "C4H10", "prod", "", "", "4.40e-10","+0.00","+00028","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "CH2s", "CH2s", "C2H2", "H", "H", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "CH2", "C2H2", "H", "H", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "CH3", "C2H4", "H", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "CH4", "CH2", "CH4", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "CH4", "CH3", "CH3", "", "5.90e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H", "C2H2", "CH", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H2", "CH2", "C2H2", "", "8.14e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H2", "C3H3", "H", "", "2.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H3", "C2H2", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H4", "CH2", "C2H4", "", "2.30e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H4", "C3H6", "", "", "1.50e-18","-3.00","-00300","1.32e-10","+00.0","+00000","3", /* cf M05 */ + "CH2s", "C2H5", "C2H4", "CH3", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H5", "C3H6", "H", "", "1.50e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H6", "CH2", "C2H6", "", "3.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C2H6", "C2H5", "CH3", "", "1.90e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H5", "C4H6", "H", "", "3.30e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H5", "C2H4", "C2H3", "", "6.67e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H6", "CH2", "C3H6", "", "5.00e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "CH2s", "C3H6", "C3H5", "CH3", "", "8.70e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H7", "C2H5", "C2H4", "", "4.29e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H7", "C3H6", "CH3", "", "1.71e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "C3H8", "C2H5", "C2H5", "", "1.60e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2s", "N2", "CH2", "N2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "CH2", "C2H2", "H", "H", "1.80e-10","+0.00","-00400","0.00e+00","+00.0","+00000","2", + "CH2", "CH2", "C2H2", "H2", "", "2.00e-11","-00.0","-00400","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "CH2", "CH3", "C2H4", "H", "", "7.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "CH4", "CH3", "CH3", "", "7.13e-12","+0.00","-05052","0.00e+00","+00.0","+00000","2", + "CH2", "CH4", "C2H6", "", "", "3.50e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "CH2", "C2H", "CH", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C2H2", "C3H2", "H2", "", "1.00e-12","-00.0","-03332","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "CH2", "C2H2", "C3H3", "H", "", "2.00e-11","+0.00","-03330","0.00e+00","+00.0","+00000","2", /* cf W04,V05 */ + "CH2", "C2H3", "CH3", "C2H2", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C2H4", "C3H5", "H", "", "5.31e-12","+0.00","-02658","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "CH2", "C2H5", "CH3", "C2H4", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C2H6", "C3H8", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "CH2", "C2H6", "CH3", "C2H5", "", "1.07e-11","+0.00","-03981","0.00e+00","+00.0","+00000","2", + "CH2", "C3H5", "C4H6", "H", "", "5.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C3H6", "C3H5", "CH3", "", "1.20e-12","+0.00","-03116","0.00e+00","+00.0","+00000","2", + "CH2", "C3H7", "CH3", "C3H6", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C3H7", "C2H4", "C2H5", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH2", "C3H8", "C4H10", "", "", "8.13e-12","+0.00","-03332","0.00e+00","+00.0","+00000","2", + "CH2", "C3H8", "C3H7", "CH3", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "CH2", "C4H2", "C4H", "CH3", "", "2.16e-11","+0.00","-02165","0.00e+00","+00.0","+00000","2", + "CH2", "C4H6" ,"CH3CCH", "C2H4", "", "6.14e-12","+0.00","-01731","0.00e+00","+0.00","+00000","2", /* Kraus 93 */ + "CH2", "C4H10", "prod", "", "", "4.30e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H5", "H", "", "8.28e-12","0.099","-05335","0.00e+00","+00.0","+00000","2", + "CH3", "CH3", "C2H6", "", "", "1.65e-04","-8.75","-00985","1.17e-10","+0.00","-00000","3", /* Cody 03 */ + "CH3", "C2H", "C3H3", "H", "", "4.00e-11","+00.0","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H2", "CH3CCH", "H", "", "3.18e-20","+2.42","-06488","0.00e+00","+0.00","+00000","2", /* Diau 94 */ + "CH3", "C2H2", "C3H5", "", "", "3.30e-30","+0.00","-00740","1.00e-12","+0.00","-03900","3", /* cf V05 */ + "CH3", "C2H3", "C2H2", "CH4", "", "3.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H3", "C3H6", "", "", "5.00e-27","+0.00","-00000","1.10e-10","+0.00","+00000","3", /* cf M05 */ + "CH3", "C2H4", "C2H3", "CH4", "", "1.10e-23","+03.7","-04780","0.00e+00","+00.0","+00000","2", + "CH3", "C2H4", "C3H7", "", "", "1.39e-29","+00.0","-00562","3.50e-13","+00.0","-03700","3", /* cf V05 */ + "CH3", "C2H5", "CH4", "C2H4", "", "3.25e-11","-0.50","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C2H5", "C3H8", "", "", "1.01e+20","-16.1","-01897","8.12e-10","-0.50","+00000","3", + "CH3", "C2H6", "CH4", "C2H5", "", "2.50e-31","+6.00","-03043","0.00e+00","+00.0","+00000","2", +// "CH3", "C3H3", "C4H6", "", "", "3.50e-06","-07.0","-01390","6.80e-11","+00.0","+00130","3", /* cf V05 */ + "CH3", "CH3CCH", "C2H6", "C2H", "", "8.32e-13","+00.0","-04428","0.00e+00","+00.0","+00000","2", + "CH3", "CH2CCH2","C2H5", "C2H2", "", "3.32e-13","+00.0","-04076","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "CH2CCH2","CH4", "", "5.00e-12","-0.32","+00066","0.00e+00","+00.0","+00000","2", + "CH3", "C3H5", "prod", "", "", "1.28e-30","-0.32","+00066","1.69e-10","-0.32","+00066","3", /* cf W04 */ + "CH3", "C3H6", "CH4", "C3H5", "", "2.66e-13","+00.0","-04440","0.00e+00","+00.0","+00000","2", + "CH3", "C3H6", "prod", "", "", "7.70e-29","+0.00","-00380","1.19e-13","+00.0","-03330","3", /* cf V05 */ + "CH3", "C3H7", "C4H10", "", "", "8.63e+28","-18.5","-02307","3.20e-10","-0.32","+00000","3", + "CH3", "C3H7", "C3H6", "CH4", "", "1.90e-11","-0.32","+00000","0.00e+00","+00.0","+00000","2", + "CH3", "C3H8", "C3H7", "CH4", "", "1.50e-24","+3.65","-03600","0.00e+00","+00.0","+00000","2", + "CH3", "C4H4", "C4H3", "CH4", "", "6.61e-13","+0.00","-02502","0.00e+00","+00.0","+00000","2", + "CH3", "C4H6", "prod", "", "", "3.30e-30","+0.00","-00740","1.30e-13","+00.0","-02060","3", /* cf V05 */ + "CH3", "C4H10", "prod", "CH4", "", "6.60e-13","-00.0","-04840","0.00e+00","+00.0","+00000","2", /* cf V05 */ +// "CH4", "C2", "CH3CCH", "", "", "1.70e-11","+0.00","-02805","0.00e+00","+00.0","+00000","2", /* Baulch 92 (3C2) */ + "CH4", "C2", "CH3", "C2H", "", "9.83e-11","-0.42","-00013","0.00e+00","+00.0","+00000","2", /* Canosa 06 (1C2) */ + "CH4", "C2H", "C2H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "CH4", "C2H3", "C2H4", "CH3", "", "2.40e-24","+4.02","-02754","0.00e+00","+00.0","+00000","2", + "CH4", "C2H5", "C2H6", "CH3", "", "1.43e-25","+4.14","-06322","0.00e+00","+00.0","+00000","2", + "CH4", "C3H5", "C3H6", "CH3", "", "6.60e-23","+3.40","-11670","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "CH4", "C3H7", "C3H8", "CH3", "", "4.00e-26","+4.02","-05473","0.00e+00","+00.0","+00000","2", + "CH4", "C4H", "C4H2", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "CH4", "AC6H5", "AC6H6", "CH3", "", "3.32e-12","+0.00","-04329","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2", "C2H2", "C4H", "H", "", "1.92e-07","-1.14","-00077","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2) + produits: Nadia B. */ + "C2", "C2H4", "C4H3", "H", "", "5.10e-08","-0.93","-00058","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2) + produits: Nadia B. */ + "C2", "C2H6", "C2H", "C2H5", "", "2.77e-08","-0.94","-00044","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2); Produits ? */ + "C2", "C3H8", "C3H7", "C2H", "", "3.89e-08","-1.31","-00094","0.00e+00","+0.00","+00000","2", /* Canosa 06 (1C2); Produits ? */ + "C2", "AC6H6", "soot", "", "", "5.20e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Reisler 80 */ + "C2H", "C2H", "C2H2", "C2", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H2", "C4H2", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C2H2", "C4H", "H2", "", "8.60e-18","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* Ralf Kaiser */ + "C2H", "C2H3", "C2H2", "C2H2", "", "1.60e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H4", "C4H4", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C2H5", "C3H3", "CH3", "", "3.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H5", "C2H2", "C2H4", "", "3.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C2H6", "C2H2", "C2H5", "", "5.10e-11","+0.00","-00076","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "CH3CCH", "C4H2", "CH3", "", "1.60e-10","+0.00","+00071","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "CH2CCH2","C2H2", "C3H3", "", "1.30e-10","+0.00","+00103","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H", "C3H5", "CH2CCH2","C2H2", "", "1.20e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H6", "prod", "H", "", "2.00e-10","+0.00","+00000","0.00e+00","+00.0","+00000","2", /* peu != de Chastaing 98 */ + "C2H", "C3H7", "C3H3", "C2H5", "", "2.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H7", "C3H6", "C2H2", "", "1.00e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H", "C3H8", "C3H7", "C2H2", "", "9.80e-11","+0.00","-00071","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C2H", "C4H6", "AC6H6", "H", "", "3.30e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "C4H10", "prod", "C2H2", "", "1.20e-10","-00.0","-00000","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H", "AC6H6", "soot", "H", "", "8.20e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* WandF 97 */ + "C2H2", "C2H3", "C4H4", "H", "", "3.32e-12","+0.00","-02516","0.00e+00","+00.0","+00000","2", + "C2H2", "C2H3", "C4H5", "", "", "8.20e-30","+0.00","-00352","4.16e-19","+1.90","-01058","3", /* cf M05 */ + "C2H2", "C2H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.60e-14","+00.0","-03520","3", /* cf V05 */ + "C2H2", "C3H5", "prod", "", "", "3.30e-30","+0.00","-00740","5.30e-14","+0.00","-03500","3", /* cf V05 */ + "C2H2", "C3H7", "C3H5", "C2H4", "", "1.20e-12","+0.00","-04531","0.00e+00","+00.0","+00000","2", + "C2H2", "C4H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pas de 1/3 */ + "C2H2", "C4H3", "soot", "", "", "2.00e-16","+0.00","-00000","0.00e+00","+0.00","+00000","2", + "C2H2", "C4H5", "AC6H6", "H", "", "3.50e-09","-1.07","-02417","0.00e+00","+0.00","+00000","2", /* WetF 94 */ + "C2H2", "C4H5", "AC6H6", "H", "", "4.20e-19","+1.80","-00602","0.00e+00","+0.00","+00000","2", /* Weismann 88 */ + "C2H2", "AC6H5", "soot", "", "", "3.72e-13","+0.00","-01561","0.00e+00","+0.00","+00000","2", /* Yu 94 */ + "C2H3", "C2H3", "C4H6", "", "", "5.00e-18","-3.75","-00300","1.40e-10","+00.0","+00000","3", /* cf M05 */ + "C2H3", "C2H3", "C2H2", "C2H4", "", "2.40e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H4", "C4H6", "H", "", "8.30e-13","+0.00","-03676","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C3H5", "CH3", "", "6.10e-47","+11.2","+03289","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H4", "C2H4", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "C2H2", "C2H6", "", "8.00e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C2H5", "prod", "", "", "1.90e-27","+0.00","+00000","2.50e-11","+00.0","+00000","3", /* cf W04 */ + "C2H3", "C2H6", "C2H4", "C2H5", "", "9.98e-22","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "CH2CCH2","C2H4", "", "4.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "C3H6", "C2H2", "", "8.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H5", "prod", "H", "H", "8.00e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H3", "C3H6", "CH3", "C4H6", "", "1.20e-12","+0.00","-02520","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "C2H4", "C3H5", "", "3.68e-24","+3.50","-02356","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H6", "prod", "H", "", "1.20e-12","+0.00","-03240","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H3", "C3H7", "C2H4", "C3H6", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "C3H8", "C2H2", "", "2.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H3", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","1.60e-11","+00.0","+00000","3", /* cf V05 */ + "C2H3", "C3H8", "C3H7", "C2H4", "", "1.00e-21","+3.30","-05285","0.00e+00","+00.0","+00000","2", + "C2H3", "C4H3", "AC6H6", "", "", "4.77e-10","+0.00","-00411","0.00e+00","+0.00","+00000","2", /* Duran 88 */ + "C2H3", "C4H5", "AC6H6", "H2", "", "3.05e-37","+7.07","-01817","0.00e+00","+0.00","+00000","2", /* Westmoreland 89 */ + "C2H3", "C4H6", "prod", "", "", "1.50e-14","-5.84","-02363","2.45e-12","-0.17","-01630","3", /* cf V05 */ + "C2H4", "C2H5", "C2H3", "C2H6", "", "1.05e-21","+3.13","-09063","0.00e+00","+00.0","+00000","2", + "C2H4", "C3H5", "prod", "H", "", "1.00e-14","+0.00","-05776","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C2H4", "C3H7", "prod", "", "", "7.70e-30","+0.00","-00380","1.80e-13","+00.0","-03670","3", /* cf V05 */ + "C2H4", "C4H", "C4H2", "C2H3", "", "4.60e-11","+0.00","+00025","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C2H4", "AC6H5", "prod", "H", "", "1.20e-12","+0.00","-02250","0.00e+00","+00.0","+00000","2", /* cf M05 */ + "C2H5", "C2H5", "C4H10", "", "", "6.59e-06","-6.39","-00301","1.26e-11","+00.0","-00096","3", + "C2H5", "C2H5", "C2H6", "C2H4", "", "2.40e-12","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* Baulch 92 */ + "C2H5", "CH2CCH2","C2H6", "C3H3", "", "5.25e-13","+0.00","-04579","0.00e+00","+0.00","+00000","2", /* Getty 67 */ + "C2H5", "C3H5", "CH2CCH2","C2H6", "", "1.60e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "C3H6", "C2H4", "", "4.30e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H5", "prod", "", "", "3.50e-07","-07.0","-01390","3.30e-11","+00.0","+00066","3", /* cf V05 */ + "C2H5", "C3H6", "C2H6", "C3H5", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H6", "prod", "", "", "7.70e-30","-00.0","-00380","1.70e-13","+00.0","+03625","3", /* cf V05 */ + "C2H5", "C3H7", "C2H6", "C3H6", "", "2.40e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "C3H8", "C2H4", "", "1.90e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C2H5", "C3H7", "prod", "", "", "9.70e+28","-18.5","-02307","3.30e-11","+00.0","+00000","3", /* cf V05 */ + "C2H5", "C3H8", "C3H7", "C2H6", "", "1.50e-24","+3.65","-04600","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H5", "C2H5", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C2H6", "C3H7", "C3H8", "C2H5", "", "4.20e-25","+3.82","-04550","0.00e+00","+00.0","+00000","2", + "C2H6", "C4H", "C4H2", "C2H5", "", "3.50e-11","+0.00","+00003","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C3H3", "AC6H6", "", "", "6.00e-28","+0.00","+01680","1.20e-10","+0.00","+00000","3", /* Moses 00, Morter 94 */ + "C3H3", "C3H5", "prod", "", "", "2.90e-11","+0.00","-00000","0.00e+00","+00.0","+00000","2", /* cf W04 */ + "C3H3", "C4H2", "CH3CCH", "C4H", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Alkernade 89 */ + "C3H5", "C3H5", "CH2CCH2","C3H6", "", "1.40e-13","+0.00","+00132","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H5", "prod", "", "", "3.50e-07","-7.00","-01390","1.70e-11","+0.00","+00132","3", /* cf V05 */ + "C3H5", "C3H6", "C2H5", "C4H4", "", "1.00e-14","+0.00","-05776","0.00e+00","+0.00","+00000","2", /* Tsang 91 */ + "C3H5", "C3H7", "C3H6", "C3H6", "", "2.40e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "CH2CCH2","C3H8", "", "1.20e-12","+0.00","+00066","0.00e+00","+00.0","+00000","2", + "C3H5", "C3H7", "prod", "", "", "3.50e-07","-7.00","-01390","3.40e-11","+0.00","+00066","3", /* cf V05 */ + "C3H5", "C3H8", "C3H7", "C3H6", "", "3.90e-22","+3.30","-09986","0.00e+00","+00.0","+00000","2", + "C3H5", "C4H10", "C3H6", "prod", "", "7.00e-23","+3.30","-07800","0.00e+00","+00.0","+00000","2", /* cf V05 */ + "C3H6", "C3H7", "C3H5", "C3H8", "", "3.70e-24","+3.50","-03340","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "C3H8", "C3H6", "", "2.80e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3H7", "C3H7", "prod", "", "", "2.90e-21","+0.00","+00000","1.70e-11","+00.0","+00000","3", /* cf V05 */ + "C4H", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", /* pad de 1/3 */ + "C4H2s", "", "C4H2", "", "", "1.00e+01","+0.00","+00000","0.00e+00","+00.0","+00000","1", + "C4H2s", "N2", "C4H2", "N2", "", "1.40e-15","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H2", "prod", "H", "H", "3.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C2H4", "prod", "H", "H", "4.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "CH3", "H", "2.30e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "CH3CCH", "prod", "C2H3", "", "8.70e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "H", "H", "1.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "CH3", "H", "4.10e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H2", "", "2.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C3H6", "prod", "C2H3", "", "4.90e-14","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "C2H2", "", "8.20e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H2", "prod", "H", "H", "1.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "soot", "H", "", "9.50e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "AC6H6", "C2H2", "", "8.80e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H2s", "C4H6", "prod", "C2H4", "", "3.60e-13","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C4H3", "C4H3", "prod", "", "", "3.50e-07","-7.00","-01390","7.00e-11","+0.00","+00000","3", /* cf V05 */ + "C4H4", "C4H4", "prod", "", "", "7.25e-14","+0.00","-09261","0.00e+00","+00.0","+00000","2", + "AC6H5", "AC6H6", "prod", "", "", "1.59e-12","+0.00","-02168","0.00e+00","+00.0","+00000","2", /* cf W04 */ + + "N4S", "N4S", "N2", "", "", "8.27e-34","+0.00","+00490","0.00e+00","+00.0","+00000","3", + "N4S", "CH", "CN", "H", "", "2.67e-10","-0.09","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "HCN", "H2", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3", "H2CN", "H", "", "5.60e-11","+0.00","+00000","0.00e+00","+00.0","+00000","2", +/* "N4S", "C2H2", "CH2CN", "", "", "1.70e-14","+0.00","+00000","0.00e+00","+0.00","+00000","2", Sato 74 */ + "N4S", "C2H3", "CH3CN", "", "", "3.08e-12","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H3", "CH2CN", "H", "", "6.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Payne 96 */ + "N4S", "C2H4", "CH3", "HCN", "", "3.32e-14","+0.00","-00352","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C2H5", "HCN", "CH4", "", "1.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Stief 95 */ + "N4S", "C2H6", "prod", "", "", "0.00e-00","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "N4S", "CH3CCH", "CHCN", "CH3", "", "1.15e-13","+0.00","-00745","0.00e+00","+0.00","+00000","2", /* Kerr 72 */ + "N4S", "C3H6", "HCN", "C2H4", "H", "2.49e-13","+0.00","-00830","0.00e+00","+0.00","+00000","2", /* Paraskevopoulos 67 */ + "N4S", "C3H8", "HCN", "C2H6", "H", "3.39e-13","+0.00","-02563","0.00e+00","+0.00","+00000","2", /* Onyzchuk 53 */ + "N4S", "C4H10", "C3H8", "HCN", "H", "2.97e-14","+0.00","-01813","0.00e+00","+0.00","+00000","2", /* Back 54 */ + "N4S", "H2CN", "HCN", "prod", "", "1.00e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "N4S", "CHCN", "NCCN", "H", "", "6.00e-15","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Safrany 68 */ + "N4S", "CH3CN", "HCN", "HCN", "H", "2.28e-15","+0.00","-00813","0.00e+00","+0.00","+00000","2", /* Forst 57 */ + "CN", "H", "HCN", "", "", "2.40e-24","-2.20","-00567","2.99e-09","-0.50","+00000","3", /* Tsang 92 */ + "CN", "H2", "HCN", "H", "", "2.23e-21","+3.31","-00756","0.00e+00","+00.0","+00000","2", + "CN", "CH4", "HCN", "CH3", "", "4.64e-16","+1.53","-00504","0.00e+00","+00.0","+00000","2", /* est, Yang 93 */ + "CN", "CH4", "CH3CN", "H", "", "5.15e-17","+1.53","-00504","0.00e+00","+0.00","+00000","2", /* est, Yang 93 */ + "CN", "C2H2", "HC3N", "H", "", "5.67e-09","-0.55","-00004","0.00e+00","+00.0","+00000","2", + "CN", "C2H6", "HCN", "C2H5", "", "5.91e-12","+0.22","+00058","0.00e+00","+00.0","+00000","2", + "CN", "CH3CCH", "HC3N", "CH3", "", "2.10e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Sayah 88 */ + "CN", "CH2CCH2","HCN", "C3H3", "", "2.63e-10","+0.00","+00167","0.00e+00","+0.00","+00000","2", /* Butterfield 93 */ + "CN", "C3H6", "prod", "H", "", "1.73e-10","+0.00","+00102","0.00e+00","+0.00","+00000","2", /* Sims 93 */ + "CN", "C3H8", "C3H7", "HCN", "", "2.44e-14","+1.19","+00378","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "C4H2", "HC3N", "C2H", "", "5.26e-09","-0.52","-00019","0.00e+00","+0.00","+00000","2", /* est. Sims 93 */ + "CN", "C4H4", "C4H3", "HCN", "", "1.07e-07","-0.82","-00228","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CN", "NCCN", "", "", "9.44e-23","-2.61","+00000","9.40e-12","+0.00","+00000","3", /* Tsang 92 */ + "CN", "HCN", "NCCN", "H", "", "2.51e-17","+1.71","-00770","0.00e+00","+0.00","+00000","2", /* Yang 92 */ + "CN", "CH3CN", "NCCN", "CH3", "", "6.46e-11","+0.00","-01190","0.00e+00","+0.00","+00000","2", /* Zabarnick 89 */ + "CN", "NCCN", "prod", "", "", "2.19e-21","+2.70","-00325","0.00e+00","+00.0","+00000","2", + "CN", "HC3N", "C4N2", "H", "", "1.70e-10","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Halpern 89 */ + "CN", "C4N2", "NCCN", "C3N", "", "5.40e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Seki 96 */ + "HCN", "H", "H2CN", "", "", "4.40e-24","-2.73","-03855","5.50e-11","+00.0","-02438","3", + "HCN", "CH", "CHCN", "H", "", "5.00e-11","+0.00","+00500","0.00e+00","+0.00","+00000","2", /* Zabarnick 91 */ + "HCN", "C2H", "H", "HC3N", "", "5.26e-12","+0.00","-00770","0.00e+00","+00.0","+00000","2", + "HCN", "AC6H5", "soot", "", "", "3.72e-13","+0.00","-01561","0.00e+00","+0.00","+00000","2", + "HCN", "H2CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "H", "HCN", "H2", "", "1.40e-10","+0.00","-00200","0.00e+00","+00.0","+00000","2", + "H2CN", "H2CN", "prod", "HCN", "", "1.16e-11","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Horne 70 */ + "H2CN", "CH3CN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "NCCN", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "H2CN", "HC3N", "soot", "", "", "1.00e-12","+0.00","-00900","0.00e+00","+0.00","+00000","2", + "N2", "CH", "prod", "", "", "3.80e-25","-2.60","+00000","9.65e-11","-0.15","+00000","3", /* Fulle 96 */ + "CHCN", "H2", "CH3CN", "", "", "1.00e-13","+0.00","+00000","0.00e+00","+0.00","+00000","2", /* Adamson 97 */ + "CH2CN", "CH2CN", "C2H4", "NCCN", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* est, Hoobler 97 */ + "CH3CN", "H", "CH3", "HCN", "", "3.39e-12","+0.00","-03954","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "H", "CH4", "CN", "", "1.66e-13","+0.00","-01505","0.00e+00","+0.00","+00000","2", /* Jamieson 70 */ + "CH3CN", "C2H", "HC3N", "CH3", "", "1.80e-11","+0.00","-00769","0.00e+00","+0.00","+00000","2", /* Hoobler 97 */ + "C3N", "H2", "HC3N", "H", "", "1.20e-11","+0.00","-00998","0.00e+00","+00.0","+00000","2", + "C3N", "CH4", "HC3N", "CH3", "", "1.20e-11","+0.00","-00491","0.00e+00","+00.0","+00000","2", + "C3N", "C2H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "C2H4", "prod", "H", "", "7.80e-11","+0.00","+00134","0.00e+00","+00.0","+00000","2", + "C3N", "C2H6", "HC3N", "C2H5", "", "3.50e-11","+0.00","+00002","0.00e+00","+00.0","+00000","2", + "C3N", "C3H8", "C3H7", "HC3N", "", "6.00e-12","+0.00","+00000","0.00e+00","+00.0","+00000","2", + "C3N", "C4H2", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "C3N", "HC3N", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "H", "HCN", "C2H2", "", "1.00e-28","+0.00","-00740","0.55e-12","+00.0","-00500","3", + "HC3N", "C2H", "prod", "H", "", "8.60e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H", "prod", "H", "", "2.90e-16","+1.80","+00474","0.00e+00","+00.0","+00000","2", + "HC3N", "C4H3", "soot", "", "", "1.20e-15","+0.00","-00000","0.00e+00","+0.00","+00000","2", Index: trunk/LMDZ.TITAN.old/libf/chimtitan/comp.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/comp.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/comp.c (revision 1643) @@ -0,0 +1,547 @@ +/* comp: Compounds characteristics. */ +/* GCCM */ + +#include "titan.h" + +void comp_(char CORPS[][10], double *CT, double *TEMP, + double *MASS, double MD[][NLEV]) +{ + int i,j; + char corps[NC+1][10]; + + double m,ma,epsa,sig,siga,p; + + p = 2.976e07; /*9 10^7 R / 8 pi */ + + /* WARNING BACKGROUND GAS IS N2 */ + + ma = 28.0134e0; /* mass of background gas in g */ + siga = 3.798e0; /* Lennard-Jones length of background gas 1/10 nm */ + epsa = 71.4e0; /* Lennard-Jones energy of background gas */ + + for( i = 0; i <= NC; i++) + { + strcpy( corps[i], CORPS[i] ); + corps[i][strcspn(CORPS[i], " ")] = '\0'; + } + + for( i = 0; i <= NC-1; i++) + { + for( j = 0; j <= NLEV-1; j++ ) MD[i][j] = 0.0e0; + } + + for( i = 0; i <= NC-1; i++ ) + { + if( strcmp(corps[i], "CH4") == 0 ) + { + MASS[i] = 16.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.758e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,148.6e0) ); + } + if( strcmp(corps[i], "H") == 0 ) + { + MASS[i] = 1.01e0; + } + if( strcmp(corps[i], "H2") == 0 ) + { + MASS[i] = 2.0158e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 2.827e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,59.7e0) ); + } + if( strcmp(corps[i], "CH") == 0 ) + { + MASS[i] = 13.02e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( ( strcmp( corps[i], "CH2" ) == 0 ) || ( strcmp( corps[i], "CH2s" ) == 0 ) ) + { + MASS[i] = 14.03e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CH3") == 0 ) + { + MASS[i] = 15.03e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.7e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C") == 0 ) + { + MASS[i] = 12.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 1.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2") == 0 ) + { + MASS[i] = 24.02e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.2e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2H") == 0 ) + { + MASS[i] = 25.03e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2H3") == 0 ) + { + MASS[i] = 27.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.8e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2H4") == 0 ) + { + MASS[i] = 28.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.163e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,224.7e0) ); + } + if( strcmp(corps[i], "C2H2") == 0 ) + { + MASS[i] = 26.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.033e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,231.8e0) ); + } + if( strcmp(corps[i], "C2H5") == 0 ) + { + MASS[i] = 29.06e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2H6") == 0 ) + { + MASS[i] = 30.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.443e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,215.7e0) ); + } + if( strcmp(corps[i], "C3H2") == 0 ) + { + MASS[i] = 38.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.6e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C3H3") == 0 ) + { + MASS[i] = 39.06e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.7e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( ( strcmp(corps[i], "CH2CCH2") == 0 ) || ( strcmp(corps[i], "CH3CCH") == 0 ) ) + { + MASS[i] = 40.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.761e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,251.8e0) ); + } + if( strcmp(corps[i], "C3H5") == 0 ) + { + MASS[i] = 41.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.78e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C3H6") == 0 ) + { + MASS[i] = 42.08e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.807e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,248.9e0) ); + } + if( strcmp(corps[i], "C3H7") == 0 ) + { + MASS[i] = 43.09e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C3H8") == 0 ) + { + MASS[i] = 44.11e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.118e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,237.1e0) ); + } + if( strcmp(corps[i], "C4H") == 0 ) + { + MASS[i] = 49.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.2e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( ( strcmp(corps[i], "C4H2") == 0 )||( strcmp(corps[i], "C4H2s") == 0 ) ) + { + MASS[i] = 50.06e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.3e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C4H3") == 0 ) + { + MASS[i] = 51.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C4H4") == 0 ) + { + MASS[i] = 52.08e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C4H5") == 0 ) + { + MASS[i] = 53.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C4H6") == 0 ) + { + MASS[i] = 54.09e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.6e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C4H10") == 0 ) + { + MASS[i] = 58.13e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.687e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,531.4e0) ); + } + if( strcmp(corps[i], "C6H") == 0 ) + { + MASS[i] = 73.07e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.2e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C6H2") == 0 ) + { + MASS[i] = 74.08e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C8H2") == 0 ) + { + MASS[i] = 98.10e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 6.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "AC6H6" ) == 0 ) + { + MASS[i] = 78.1136e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) /* P. G. L. */ + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( ( strcmp( corps[i], "C6H5" ) == 0 ) || ( strcmp( corps[i], "AC6H5" ) == 0 ) ) + { + MASS[i] = 77.1136e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "C6H6" ) == 0 ) + { + MASS[i] = 78.1136e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 5.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "N2") == 0 ) + { + MASS[i] = 28.0134e0; + } + if( strcmp(corps[i], "N4S") == 0 ) + { + MASS[i] = 14.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 1.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "NH") == 0 ) + { + MASS[i] = 15.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CN") == 0 ) + { + MASS[i] = 26.02e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.2e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "HCN") == 0 ) + { + MASS[i] = 27.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.63e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,569.1e0) ); + } + if( strcmp(corps[i], "H2CN") == 0 ) + { + MASS[i] = 28.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.8e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "C2N") == 0 ) /* C2N */ + { + MASS[i] = 39.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "CHCN" ) == 0 ) + { + MASS[i] = 39.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "CH2CN" ) == 0 ) + { + MASS[i] = 40.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "CH3CN" ) == 0 ) + { + MASS[i] = 41.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "C2H3CN" ) == 0 ) + { + MASS[i] = 53.06e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "NCCN") == 0 ) /* NCCN */ + { + MASS[i] = 52.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.361e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,348.6e0) ); + } + if( strcmp(corps[i], "C3N") == 0 ) /* C3N */ + { + MASS[i] = 50.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "HC3N") == 0 ) /* HC3N */ + { + MASS[i] = 51.05e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp( corps[i], "C4N2" ) == 0 ) + { + MASS[i] = 76.1e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "H2O") == 0 ) + { + MASS[i] = 18.02e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 2.641e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,809.1e0) ); + } + if( ( strcmp(corps[i], "O3P") == 0 ) || ( strcmp(corps[i], "O1D") == 0 ) ) + { + MASS[i] = 16.0e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 1.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "OH") == 0 ) + { + MASS[i] = 17.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.0e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "HO2") == 0 ) + { + MASS[i] = 33.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "H2O2") == 0 ) + { + MASS[i] = 33.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "O2") == 0 ) + { + MASS[i] = 32.0e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.7e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "O3") == 0 ) + { + MASS[i] = 32.0e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.7e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CO") == 0 ) + { + MASS[i] = 28.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.69e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,91.7e0) ); + } + if( strcmp(corps[i], "HCO") == 0 ) + { + MASS[i] = 29.02e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.7e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CO2") == 0 ) + { + MASS[i] = 44.01e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.941e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,195.2e0) ); + } + if( strcmp(corps[i], "CH2CO") == 0 ) + { + MASS[i] = 42.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 4.5e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CH2O") == 0 ) + { + MASS[i] = 30.03e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.75e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( ( strcmp(corps[i], "CH2OH") == 0 ) || ( strcmp(corps[i], "CH3O") == 0 ) ) + { + MASS[i] = 31.04e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.4e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) / ( CT[j] * sig ); + } + if( strcmp(corps[i], "CH3OH") == 0 ) + { + MASS[i] = 32.042e0; + m = ( ma + MASS[i] ) / ( ma * MASS[i] ); + sig = 1.0e-16 * pow( ( siga + 3.626e0 ), 2.0e0 ); + for( j = 0; j <= NLEV-1; j++ ) + MD[i][j] = sqrt( p * TEMP[j] * m ) + / ( CT[j] * sig * omega(TEMP[j],epsa,481.8e0) ); + } + } +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/disso.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/disso.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/disso.c (revision 1643) @@ -0,0 +1,390 @@ +/* disso: photodissociation rates */ +/* GCCM */ +/* correspond a chimie_simpnit (version 301105) */ +/* !!! ATTENTION !!! */ +/* Doit etre mis a jour en fonction de la chimie utilisee ! */ + +#include "titan.h" + +void disso_( double KRPD[][NLRT][RDISS+1][15], int *NLAT ) +{ + static double sH2[62] = { /* incertain en dessous de 70 et en dessus de 85... */ + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,1.000e-18,5.000e-18,1.000e-17, + 9.000e-18,6.500e-18,1.000e-18,1.000e-19 }; + static double sCH4[62] = { + 2.852e-19,7.816e-19,1.534e-18,2.069e-18,2.795e-18,4.088e-18,4.543e-18, + 4.223e-18,3.314e-18,1.565e-18,8.892e-19,8.760e-19,8.792e-19,9.163e-19, + 2.069e-18,9.378e-18,2.543e-17,3.785e-17,4.066e-17,3.302e-17,2.840e-17, + 1.800e-17,1.920e-17,1.820e-17,1.840e-17,1.140e-17,2.656e-18,1.256e-19, + 7.988e-22,1.366e-23,6.740e-24 }; + static double sCH3CN[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,8.000e-17,8.000e-17,7.500e-17, + 4.800e-17,3.700e-17,2.700e-17,4.100e-17,1.000e-17,8.600e-18,4.000e-18, + 1.800e-18,1.100e-18,6.400e-19,3.600e-19,2.000e-19,1.200e-19,5.200e-20}; + static double sC2H2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,3.000e-17, + 3.000e-17,3.200e-17,3.640e-17,4.260e-17,1.040e-16,9.900e-18,4.800e-18, + 1.720e-17,1.782e-17,9.040e-19,9.600e-19,1.294e-18,1.352e-18,1.130e-18, + 6.680e-19,3.700e-19,3.900e-19,1.660e-19,5.400e-20 }; + static double sC2H4[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,.1992E-16,.2734E-16,.2594E-16,.1690E-16,.2258E-16,.8507E-17, + .1583E-16,.2227E-16,.3056E-16,.3743E-16,.3788E-16,.2737E-16,.3171E-17, + .6033E-18,.1223E-18,.7247E-19,1.000e-20 }; + static double sC2H3CN[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e-00,0.000e-00,0.000e-00, + 0.000e-00,0.000e-00,1.000e-17,6.600e-18,5.600e-18,3.600e-18,4.300e-18, + 4.000e-18,3.000e-18,2.900e-18,2.700e-18,2.700e-18,3.300e-18,4.500e-18, + 6.000e-18,7.100e-18,7.000e-18,5.000e-18,2.500e-18,6.600e-19,1.000e-19, + 1.500e-20,1.000e-21}; + static double sC2H6[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,2.000e-17, + 2.000e-17,2.000e-17,2.060e-17,2.160e-17,1.540e-17,8.060e-18,3.860e-18, + 1.484e-18,3.060e-19,9.600e-21 }; + static double sCH3C2H[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,1.000e-17, + 2.000e-17,4.580e-17,6.240e-17,5.880e-17,5.920e-17,1.940e-17,2.200e-17, + 2.820e-17,3.380e-17,1.142e-17,6.600e-18,8.100e-18,7.000e-18,2.800e-18, + 1.600e-18,2.300e-19,4.411e-19,2.119e-19,1.004e-19,2.934e-20,4.157e-21 }; + static double sCH2CCH2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,2.200e-17,2.200e-17,1.700e-17,1.700e-17,1.800e-17, + 1.200e-17,1.500e-17,1.000e-17,2.100e-17,3.300e-17,4.000e-17,1.300e-17, + 5.000e-18,2.900e-18,2.601e-18,1.037e-18,9.046e-19,6.565e-19,4.672e-19, + 3.047e-19,1.579e-19,5.943e-20,2.261e-20 }; + static double sC3H6[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,3.400e-17, + 3.300e-17,2.400e-17,2.500e-17,4.000e-17,3.700e-17,2.300e-17,1.900e-17, + 2.000e-17,1.500e-17,2.200e-17,2.500e-17,4.400e-17,4.200e-17,2.700e-17, + 1.200e-17,5.800e-18,1.400e-19,9.100e-21 }; + static double sC3H8[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,4.000e-17,4.000e-17,4.000e-17, + 4.000e-17,4.000e-17,3.280e-17,3.100e-17,2.680e-17,2.200e-17,1.760e-17, + 6.440e-18,3.000e-18,9.140e-19,7.000e-20 }; + static double sC4H2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,2.500e-17,6.100e-17,4.780e-17,5.780e-17,1.014e-16, + 5.200e-17,4.200e-17,1.030e-16,1.770e-16,9.100e-17,1.290e-17,2.380e-18, + 3.400e-19,2.800e-19,2.600e-19,1.513e-19,2.583e-19,3.353e-19,4.115e-19, + 4.755e-19,4.990e-19,4.399e-19,5.358e-19,2.485e-19,3.931e-19,1.067e-19, + 3.761e-20,2.370e-20,2.277e-20 }; + static double sC4H4[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,4.200e-17,5.000e-17,2.000e-17,6.700e-18, + 6.100e-18,8.000e-18,1.000e-17,1.400e-17,1.900e-17,2.200e-17,2.600e-17, + 1.600e-17,1.600e-17,4.000e-18,5.700e-19,1.400e-19 }; + static double sC4H6[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,6.000e-18,1.200e-17,1.500e-17,1.300e-17, + 1.800e-17,3.100e-17,3.800e-17,6.600e-17,9.600e-17,1.060e-16,8.500e-17, + 6.700e-17,1.100e-17,1.700e-18,3.300e-19,6.500e-20 }; + static double sC4H10[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,6.000e-17,6.000e-17,6.000e-17, + 6.000e-17,6.000e-17,5.500e-17,4.400e-17,4.400e-17,3.800e-17,3.100e-17, + 1.900e-17,4.000e-18,1.300e-18,3.200e-19,2.000e-20 }; + static double sC6H6[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,7.000e-17, + 8.000e-17,5.000e-17,3.500e-17,3.500e-17,3.500e-17,2.000e-17,1.500e-17, + 1.500e-17,1.500e-17,2.000e-17,2.500e-17,4.000e-17,9.500e-17,2.200e-16, + 1.000e-16,2.000e-17,2.000e-17,2.000e-17,2.000e-17,5.000e-18,1.000e-20, + 1.000e-20,1.000e-20,1.000e-20,1.000e-20,1.000e-19,2.000e-19,2.500e-19, + 4.000e-19,2.000e-19,2.000e-19,1.000e-19 }; + static double sN2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,4.898e-18,1.097e-17, + 2.192e-17,2.214e-17,2.336e-17,1.679e-17,1.893e-17 }; + static double sHCN[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,2.800e-17,3.300e-17,2.800e-17,3.500e-17, + 4.800e-17,2.800e-17,1.700e-17,3.600e-18,2.500e-18,4.700e-18,2.700e-18, + 8.600e-19,4.400e-19,2.000e-19,1.429e-19,1.145e-19,7.482e-20,3.852e-20, + 1.009e-20 }; + static double sHC3N[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,3.402e-17, + 3.647e-17,4.317e-17,3.759e-17,7.927e-17,3.796e-17,9.565e-17,1.716e-16, + 1.247e-16,2.360e-17,8.411e-18,4.400e-18,8.600e-19,7.400e-19,6.200e-19, + 4.899e-19,3.307e-19,2.128e-19,2.561e-19,2.621e-19,2.737e-19,3.601e-19, + 1.564e-19,1.816e-19,8.427e-20 }; + static double sC2N2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,2.635e-17, + 3.126e-17,4.392e-17,9.788e-17,1.682e-16,1.064e-16,6.513e-18,2.039e-18, + 2.828e-18,5.136e-18,8.188e-18,8.857e-18,1.489e-18,9.000e-20,6.200e-20, + 3.800e-20,4.483e-20,8.618e-20,1.008e-19,7.579e-20,6.666e-20,2.907e-20, + 2.476e-20,1.142e-20 }; + static double sH2O[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,1.927e-17,9.633e-18,7.440e-18, + 1.087e-18,8.600e-18,8.850e-18,7.300e-18,4.100e-18,1.240e-18,5.600e-19, + 7.977e-19,1.888e-18,3.333e-18,4.729e-18,4.963e-18,3.513e-18,1.440e-18, + 1.563e-19 }; + static double sCO[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,7.300e-17,2.050e-16,9.000e-17,7.180e-18,3.700e-17}; + static double sCO2[62] = { + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, + 0.000e+00,1.022e-19,1.070e-19,4.220e-19,8.220e-19,6.640e-19,5.650e-19, + 5.850e-19,4.400e-19,2.100e-19,8.700e-20,4.000e-20,2.130e-20,3.700e-21, + 6.930e-22,4.040e-22,2.470e-23,4.800e-24,9.500e-25 }; + static double sol[62] = { + 9.45e+08,2.84e+08,4.24e+09,3.11e+09,1.22e+10,6.83e+09,2.54e+09,8.20e+08, + 1.82e+09,1.30e+09,1.05e+09,1.37e+09,3.87e+08,4.29e+08,2.45e+09,4.09e+09, + 1.06e+10,1.03e+10,4.08e+09,2.98e+10,7.00e+09,1.94e+09,7.40e+09,4.12e+11, + 1.36e+10,4.92e+10,3.04e+10,3.81e+10,5.49e+10,1.00e+11,1.26e+11,1.67e+11, + 2.97e+11,4.92e+11,7.17e+11,9.43e+11,1.34e+12,1.96e+12,2.96e+12,4.34e+12, + 7.25e+12,1.76e+13,2.21e+13,3.10e+13,2.80e+13,2.97e+13,3.03e+13,3.77e+13, + 3.44e+13,3.42e+13,7.08e+13,9.58e+13,1.63e+14,1.38e+14,1.26e+14,1.60e+14, + 2.23e+14,3.70e+14,3.31e+14,3.26e+14,3.59e+14,4.05e+14}; + + int i,j,l,s,lat,x; + double f,**flux; + double flact; + char name[60],dir[24]; + FILE *fp,*out; + + flux = dm2d(0,NLRT,0,14); + +/* lecture des flux actiniques: + - suppose que l'executable est dans $LMDGCM/RUN/xxx/ + - et les moyennes dans $LMDGCM/INPUT/PHOT(NLAT)/Moy_(lat:1 a NLAT) +*/ + strcpy( dir, "../../INPUT/PHOT" ); + if( (*NLAT) < 10 ) + { + strcat( dir, "0" ); + strcat( dir, (const char *)ecvt((float)(*NLAT),1,&x,&x) ); + } + else + strcat( dir, (const char *)ecvt((float)(*NLAT),2,&x,&x) ); + strcat( dir, "x/Moy_" ); + printf( "Directories for actinic fluxes: %s \n", dir ); + + for( lat = 0; lat <= (*NLAT)-1; lat++ ) /* Old array is set equal to 0. */ + for( j = 0; j <= NLRT-1; j++ ) + for( i = 0; i <= RDISS; i++ ) + for( s = 0; s <= 14; s++ ) + KRPD[lat][j][i][s] = 0.0e0; + + for( i = 0; i <= 13; i++ ) sCH4[i] = 0.0e0; + for( i = 0; i <= 13; i++ ) sC2H2[i] = 0.0e0; + for( i = 0; i <= 16; i++ ) sC2H4[i] = 0.0e0; + for( i = 0; i <= 16; i++ ) sC2H6[i] = 0.0e0; + + for( lat = 0; lat <= (*NLAT)-1; lat++ ) /* Main loop on latitude */ + for( i = 10; i <= 310; i += 5 ) /* Main loop on wavelength. */ + { + strcpy( name, dir ); + if( (lat+1) < 10 ) + { + strcat( name, "0" ); + strcat( name, (const char *)ecvt((float)(lat+1),1,&x,&x) ); + } + else + strcat( name, (const char *)ecvt((float)(lat+1),2,&x,&x) ); + if( i < 160 ) strcat( name, "/photmoy3a" ); + else strcat( name, "/photmoy3a" ); + if( i < 100 ) + { + strcat( name, ".0" ); + strcat( name, (const char *)ecvt((float)i,2,&x,&x) ); + } + else + { + strcat( name, "." ); + strcat( name, (const char *)ecvt((float)i,3,&x,&x) ); + } + if( !( fp = fopen( name, "r" ) ) ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "I cannot open %s\n", name ); + fclose( out ); + exit(0); + } + for( j = 0; j <= NLRT-1; j++ ) + { + fscanf( fp,"%d ",&l ); + for( s = 0; s < 15; s++ ) + { + fscanf( fp,"%lg ", &flact ); + flux[j][s] = flact; + } + } + fclose(fp); + + l = i / 5 - 2; /* Pointer on wavelength. */ + +/* taux de photodissociations */ + + for( s = 0; s <= 14; s++ ) + for( j = 0; j <= NLRT-1; j++ ) + { + f = flux[j][s] * sol[l] / ( 9.5e0 * 9.5e0 ); /* !! # de reac de 0 a RDISS-1 !! */ + if( i == 220 ) KRPD[lat][j][1][s] += 4.4e-17 * f; /* CH3 -> 1CH2 + H */ + KRPD[lat][j][ 0][s] += sH2[l] * f * 1.00; /* H2 -> H + H */ + KRPD[lat][j][ 7][s] += sC2H4[l] * f * 0.51; /* C2H4 -> C2H2 + H2 */ + KRPD[lat][j][ 8][s] += sC2H4[l] * f * 0.49; /* C2H4 -> C2H2 + 2H */ + KRPD[lat][j][15][s] += sCH2CCH2[l]* f * 0.89; /* CH2CCH2 -> C3H3 + H Jackson 91 */ + KRPD[lat][j][16][s] += sCH2CCH2[l]* f * 0.11; /* CH2CCH2 -> C3H2 + H2 Jackson 91 */ + KRPD[lat][j][17][s] += sCH3C2H[l] * f * 0.89; /* CH3C2H -> C3H3 + H Jackson 91 */ + KRPD[lat][j][18][s] += sCH3C2H[l] * f * 0.11; /* CH3C2H -> C3H2 + H2 Jackson 91 */ + KRPD[lat][j][19][s] += sC3H6[l] * f * 0.33; /* C3H6 -> CH2CCH2 + H2 */ + KRPD[lat][j][20][s] += sC3H6[l] * f * 0.17; /* C3H6 -> CH3CCH + H2 */ + KRPD[lat][j][21][s] += sC3H6[l] * f * 0.03; /* C3H6 -> C2H4 + 3CH2 */ + KRPD[lat][j][22][s] += sC3H6[l] * f * 0.35; /* C3H6 -> C2H3 + CH3 */ + KRPD[lat][j][23][s] += sC3H6[l] * f * 0.05; /* C3H6 -> C2H2 + CH4 */ + KRPD[lat][j][32][s] += sC4H4[l] * f * 0.80; /* C4H4 -> C4H2 + H2 Gladstone 96 */ + KRPD[lat][j][33][s] += sC4H4[l] * f * 0.20; /* C4H4 -> C2H2 + C2H2 Gladstone 96 */ + KRPD[lat][j][34][s] += sC4H6[l] * f * 0.04; /* C4H6 -> C4H4 + H2 */ + KRPD[lat][j][35][s] += sC4H6[l] * f * 0.27; /* C4H6 -> C2H4 + C2H2 */ + KRPD[lat][j][36][s] += sC4H6[l] * f * 0.69; /* C4H6 -> CH3 + C3H3 */ + KRPD[lat][j][45][s] += sC6H6[l] * f * 0.04; /* AC6H6 -> C5H3 (prod...) + CH3 */ + KRPD[lat][j][46][s] += sC6H6[l] * f * 0.96; /* AC6H6 -> AC6H5 + H */ + KRPD[lat][j][47][s] += sN2[l] * f; /* N2 -> 2N2d */ + KRPD[lat][j][48][s] += sHCN[l] * f; /* HCN -> H + CN */ + KRPD[lat][j][51][s] += sC2N2[l] * f * 0.3; /* C2N2 -> 2CN */ + KRPD[lat][j][52][s] += sCH3CN[l] * f * 1.0; /* CH3CN -> CH3 + CN */ + KRPD[lat][j][53][s] += sC2N2[l] * f * 0.3; /* C4N2 -> C3N + CN */ + + if( i != 125 ) /* Not Lyman alpha */ + { + KRPD[lat][j][ 2][s] += sCH4[l] * f; /* CH4 -> 1CH2 + H2 */ + KRPD[lat][j][ 9][s] += sC2H6[l] * f * 0.56; /* C2H6 -> C2H4 + H2 */ + KRPD[lat][j][10][s] += sC2H6[l] * f * 0.14; /* C2H6 -> C2H4 + 2H */ + KRPD[lat][j][11][s] += sC2H6[l] * f * 0.27; /* C2H6 -> C2H2 + 2H2 */ + KRPD[lat][j][12][s] += sC2H6[l] * f * 0.02; /* C2H6 -> CH4 + 3CH2 */ + KRPD[lat][j][13][s] += sC2H6[l] * f * 0.01; /* C2H6 -> 2CH3 */ + KRPD[lat][j][24][s] += sC3H8[l] * f * 0.94; /* C3H8 -> C3H6 + H2 */ + KRPD[lat][j][27][s] += sC3H8[l] * f * 0.06; /* C3H8 -> C2H4 + CH4 */ + } + else /* Lyman alpha */ + { + KRPD[lat][j][ 2][s] += sCH4[l] * f * 0.64; /* CH4 -> 1CH2 + H2 */ + KRPD[lat][j][ 3][s] += sCH4[l] * f * 0.07; /* CH4 -> CH + H2 + H */ + KRPD[lat][j][ 4][s] += sCH4[l] * f * 0.29; /* CH4 -> CH3 + H */ + KRPD[lat][j][ 9][s] += sC2H6[l] * f * 0.13; /* C2H6 -> C2H4 + H2 */ + KRPD[lat][j][10][s] += sC2H6[l] * f * 0.3; /* C2H6 -> C2H4 + 2H */ + KRPD[lat][j][11][s] += sC2H6[l] * f * 0.25; /* C2H6 -> C2H2 + 2H2 */ + KRPD[lat][j][12][s] += sC2H6[l] * f * 0.25; /* C2H6 -> CH4 + 3CH2 */ + KRPD[lat][j][13][s] += sC2H6[l] * f * 0.08; /* C2H6 -> 2CH3 */ + KRPD[lat][j][24][s] += sC3H8[l] * f * 0.33; /* C3H8 -> C3H6 + H2 */ + KRPD[lat][j][25][s] += sC3H8[l] * f * 0.09; /* C3H8 -> C2H6 + 3CH2 */ + KRPD[lat][j][26][s] += sC3H8[l] * f * 0.39; /* C3H8 -> C2H5 + CH3 */ + KRPD[lat][j][27][s] += sC3H8[l] * f * 0.2; /* C3H8 -> C2H4 + CH4 */ + } + if( i < 145 ) /* C4H10: a revoir avec Jackson & Lias, 1974... */ + { + KRPD[lat][j][37][s] += sC4H10[l]* f * 0.18; /* C4H10 -> C4H8(ieC3H5+CH3)+H2 */ + KRPD[lat][j][38][s] += sC4H10[l]* f * 0.20; /* C4H10 -> 2 C2H4 + H2 */ + KRPD[lat][j][39][s] += sC4H10[l]* f * 0.03; /* C4H10 -> C3H6 + CH4 */ + KRPD[lat][j][40][s] += sC4H10[l]* f * 0.07; /* C4H10 -> C3H6 + CH3 + H */ + KRPD[lat][j][41][s] += sC4H10[l]* f * 0.00; /* C4H10 -> C2H6 + C2H4 */ + KRPD[lat][j][42][s] += sC4H10[l]* f * 0.15; /* C4H10 -> C2H6 + C2H2 + H2 */ + KRPD[lat][j][43][s] += sC4H10[l]* f * 0.27; /* C4H10 -> CH3 + C3H7 */ + KRPD[lat][j][44][s] += sC4H10[l]* f * 0.10; /* C4H10 -> 2 C2H5 */ + } + else + { + KRPD[lat][j][37][s] += sC4H10[l]* f * 0.41; /* C4H10 -> C4H8(ieC3H5+CH3)+H2 */ + KRPD[lat][j][38][s] += sC4H10[l]* f * 0.12; /* C4H10 -> 2 C2H4 + H2 */ + KRPD[lat][j][39][s] += sC4H10[l]* f * 0.01; /* C4H10 -> C3H6 + CH4 */ + KRPD[lat][j][40][s] += sC4H10[l]* f * 0.07; /* C4H10 -> C3H6 + CH3 + H */ + KRPD[lat][j][41][s] += sC4H10[l]* f * 0.02; /* C4H10 -> C2H6 + C2H4 */ + KRPD[lat][j][42][s] += sC4H10[l]* f * 0.06; /* C4H10 -> C2H6 + C2H2 + H2 */ + KRPD[lat][j][43][s] += sC4H10[l]* f * 0.24; /* C4H10 -> CH3 + C3H7 */ + KRPD[lat][j][44][s] += sC4H10[l]* f * 0.07; /* C4H10 -> 2 C2H5 */ + } + if( i < 150 ) + { + KRPD[lat][j][ 5][s] += sC2H2[l] * f * 0.3; /* C2H2 -> C2H + H */ + KRPD[lat][j][ 6][s] += sC2H2[l] * f * 0.1; /* C2H2 -> C2 + H2 */ + KRPD[lat][j][49][s] += sHC3N[l] * f * 0.3; /* HC3N -> C2H + CN */ + KRPD[lat][j][50][s] += sHC3N[l] * f * 0.09; /* HC3N -> H + C3N */ + } + else if( i < 205 ) + { + KRPD[lat][j][ 5][s] += sC2H2[l] * f * 0.08; /* C2H2 -> C2H + H */ + KRPD[lat][j][ 6][s] += sC2H2[l] * f * 0.1; /* C2H2 -> C2 + H2 */ + KRPD[lat][j][49][s] += sHC3N[l] * f * 0.05; /* HC3N -> C2H + CN */ + KRPD[lat][j][50][s] += sHC3N[l] * f * 0.09; /* HC3N -> H + C3N */ + } + else if( i < 245 ) + { + KRPD[lat][j][50][s] += sHC3N[l] * f * 0.09; /* HC3N -> H + C3N */ + } + if( i < 165 ) + { + KRPD[lat][j][28][s] += sC4H2[l] * f * 0.2; /* C4H2 -> C4H + H */ + KRPD[lat][j][29][s] += sC4H2[l] * f * 0.03; /* C4H2 -> 2C2H */ + KRPD[lat][j][30][s] += sC4H2[l] * f * 0.1; /* C4H2 -> C2H2 + C2 */ + KRPD[lat][j][31][s] += sC4H2[l] * f * 0.67; /* C4H2 -> C4H2* */ + } + else if( i < 205 ) + { + KRPD[lat][j][29][s] += sC4H2[l] * f * 0.01; /* C4H2 -> 2C2H */ + KRPD[lat][j][30][s] += sC4H2[l] * f * 0.06; /* C4H2 -> C2H2 + C2 */ + KRPD[lat][j][31][s] += sC4H2[l] * f * 0.93; /* C4H2 -> C4H2* */ + } + else + { + KRPD[lat][j][31][s] += sC4H2[l] * f * 1.00; /* C4H2 -> C4H2* */ + } + if( i < 190 ) KRPD[lat][j][14][s] += 4.e-17 * f; /* C3H3 -> C3H2 + H */ + } + } + +/* taux de dissociation de N2 ( e- et GCR ) */ + + for( lat = 0; lat <= (*NLAT)-1; lat++ ) + for( s = 0; s <= 14; s++ ) + { + for( j = 99; j <= NLRT-1; j++ ) /* level 100 = 200 km */ + KRPD[lat][j][RDISS][s] = 1.0e-16; + for( j = 49; j <= 98; j++ ) /* level 50 = 100 km */ + KRPD[lat][j][RDISS][s] = 1.0e-17+1.8e-18*(j-49); + for( j = 34; j <= 48; j++ ) /* level 35 = 70 km */ + KRPD[lat][j][RDISS][s] = pow(10.,(-23+0.4*(j-34))); + for( j = 0; j <= 33; j++ ) + KRPD[lat][j][RDISS][s] = 0.0e0; + } + + fdm2d( flux, 0, NLEV, 0 ); +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/dmxd.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/dmxd.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/dmxd.c (revision 1643) @@ -0,0 +1,345 @@ +#include +#include +#include +#include + + /* dm1d: memory allocation for a vector of double */ + /* ---------------------------------------------- */ + +double *dm1d( int nl, int nh ) +{ + double *m; + FILE *out; + + m = (double *)calloc( (unsigned)(nh-nl+1), sizeof(double) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in dm1d" ); + fclose( out ); + exit(0); + } + return m-nl; +} + + /* dm2d: memory allocation for a matrix of double */ + /* ---------------------------------------------- */ + +double **dm2d( int nrl, int nrh, int ncl, int nch ) +{ + int i; + double **m; + FILE *out; + + m = (double **)calloc( (unsigned)(nrh-nrl+1), sizeof(double *) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in dm2d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + { + m[i] = (double *)calloc( (unsigned)(nch-ncl+1), sizeof(double) ); + if(!m[i]) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in dm2d" ); + fclose( out ); + exit(0); + } + m[i] -= ncl; + } + return m; +} + + /* dm3d: memory allocation for a 3D vector of double */ + /* ------------------------------------------------- */ + +double ***dm3d( int nrl, int nrh, int ncl, int nch, int nal, int nah ) +{ + int i; + double ***m; + FILE *out; + + m = (double ***)calloc( (unsigned)(nrh-nrl+1), sizeof(double **) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in dm3d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + m[i] = dm2d( ncl, nch, nal, nah ); + return m; +} + + /* dm4d: memory allocation for a 4D vector of double */ + /* ------------------------------------------------- */ + +double ****dm4d( int nrl, int nrh, int ncl, int nch, int nal, int nah, int nll, int nlh ) +{ + int i; + double ****m; + FILE *out; + + m = (double ****)calloc( (unsigned)(nrh-nrl+1), sizeof(double ***) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in dm4d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + m[i] = dm3d( ncl, nch, nal, nah, nll, nlh ); + return m; +} + + /* fdm1d: release a vector of double */ + /* --------------------------------- */ + +void fdm1d(v,nl) +double *v; +int nl; +{ + free((char *)(v+nl)); +} + + /* fdm2d: release a matrix of double */ + /* --------------------------------- */ + +void fdm2d(m,nrl,nrh,ncl) +double **m; +int ncl,nrh,nrl; +{ + int i; + + for( i = nrh; i >= nrl; i-- ) free((char *)(m[i]+ncl)); + free((char *)(m+nrl)); +} + + /* fdm3d: release a 3D vector of double */ + /* ------------------------------------ */ + +void fdm3d(m,nrl,nrh,ncl,nch,nal) +double ***m; +int nch,ncl,nrh,nrl,nal; +{ + int i; + + for( i = nrh; i >= nrl; i-- ) fdm2d(m[i],ncl,nch,nal); + free((char *)(m+nrl)); +} + + /* frm1d: release a vector of float */ + /* -------------------------------- */ + +void frm1d(v,nl) +float *v; +int nl; +{ + free((char *)(v+nl)); +} + + /* frm2d: release a matrix of float */ + /* -------------------------------- */ + +void frm2d(m,nrl,nrh,ncl) +float **m; +int ncl,nrh,nrl; +{ + int i; + + for( i = nrh; i >= nrl; i-- ) free((char *)(m[i]+ncl)); + free((char *)(m+nrl)); +} + + /* frm3d: release a 3D vector of float */ + /* ----------------------------------- */ + +void frm3d(m,nrl,nrh,ncl,nch,nal) +float ***m; +int nch,ncl,nrh,nrl,nal; +{ + int i; + + for( i = nrh; i >= nrl; i-- ) frm2d(m[i],ncl,nch,nal); + free((char *)(m+nrl)); +} + + /* rm1d: memory allocation for a vector of float */ + /* --------------------------------------------- */ + +float *rm1d( int nl, int nh ) +{ + float *m; + FILE *out; + + m = (float *)calloc( (unsigned)(nh-nl+1), sizeof(float) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in rm1d" ); + fclose( out ); + exit(0); + } + return m-nl; +} + + /* rm2d: memory allocation for a matrix of float */ + /* --------------------------------------------- */ + +float **rm2d( int nrl, int nrh, int ncl, int nch ) +{ + int i; + float **m; + FILE *out; + + m = (float **)calloc( (unsigned)(nrh-nrl+1), sizeof(float *) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in rm2d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + { + m[i] = (float *)calloc( (unsigned)(nch-ncl+1), sizeof(float) ); + if(!m[i]) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in rm2d" ); + fclose( out ); + exit(0); + } + m[i] -= ncl; + } + return m; +} + + /* rm3d: memory allocation for a 3D vector of float */ + /* ------------------------------------------------ */ + +float ***rm3d( int nrl, int nrh, int ncl, int nch, int nal, int nah ) +{ + int i; + float ***m; + FILE *out; + + m = (float ***)calloc( (unsigned)(nrh-nrl+1), sizeof(float **) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in rm3d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + m[i] = rm2d( ncl, nch, nal, nah ); + return m; +} + + /* rm4d: memory allocation for a 4D vector of float */ + /* ------------------------------------------------ */ + +float ****rm4d( int nrl, int nrh, int ncl, int nch, int nal, int nah, int nll, int nlh ) +{ + int i; + float ****m; + FILE *out; + + m = (float ****)calloc( (unsigned)(nrh-nrl+1), sizeof(float ***) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in rm4d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + m[i] = rm3d( ncl, nch, nal, nah, nll, nlh ); + return m; +} + + /* im1d: memory allocation for a vector of integer */ + /* ----------------------------------------------- */ + +int *im1d( int nl, int nh ) +{ + int *m; + FILE *out; + + m = (int *)calloc( (unsigned)(nh-nl+1), sizeof(int ) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in im1d" ); + fclose( out ); + exit(0); + } + return m-nl; +} + + /* im2d: memory allocation for a matrix of integer */ + /* ----------------------------------------------- */ + +int **im2d( int nrl, int nrh, int ncl, int nch ) +{ + int i,**m; + FILE *out; + + m = (int **)calloc( (unsigned)(nrh-nrl+1), sizeof(int *) ); + if( !m ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in im2d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + { + m[i] = (int *)calloc( (unsigned)(nch-ncl+1), sizeof(int) ); + if(!m[i]) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in im2d" ); + fclose( out ); + exit(0); + } + m[i] -= ncl; + } + return m; +} + + /* im3d: memory allocation for a 3D vector of integer */ + /* -------------------------------------------------- */ + +int ***im3d( int nrl, int nrh, int ncl, int nch, int nal, int nah ) +{ + int i,***m; + FILE *out; + + m = (int ***)calloc( (unsigned)(nrh-nrl+1), sizeof(int **) ); + if(!m) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Memory allocation error in im3d" ); + fclose( out ); + exit(0); + } + m -= nrl; + for( i = nrl; i <= nrh; i++ ) + m[i] = im2d( ncl, nch, nal, nah ); + return m; +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/gptitan.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/gptitan.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/gptitan.c (revision 1643) @@ -0,0 +1,919 @@ +/* gptitan: photochimie */ +/* GCCM */ + +/* tout est passe en simple precision */ +/* sauf pour l'inversion de la matrice */ + +/* nitriles et hydrocarbures separes pour l'inversion */ + +/* flux variable au sommet */ + +#include "titan.h" + +void gptitan_( + double *RA, double *TEMP, double *NB, + char CORPS[][10], double Y[][NLEV], + double *FIN, int *LAT, double *MASS, double MD[][NLEV], + double *KEDD, double *botCH4, double KRATE[][NLEV], + int reactif[][5], int *nom_prod, int *nom_perte, + int prod[][200], int perte[][200][2], int *aerprod, int *utilaer, + double MAER[][NLEV], double PRODAER[][NLEV], + double CSN[][NLEV], double CSH[][NLEV], + int *htoh2, double *surfhaze) +{ + char outlog[100],corps[100][10]; + int i,j,k,l; + int ireac,ncom1,ncom2; + double ***a,***b,**c; + double *fl,*fp,*mu,**jac,**ym1,**f; + double fluxCH4; + double conv,delta,deltamax; + double cm,cp,dim,dip,dm,dp,dym,dyp,km,kp,r,dra,dram,drap; + double np,nm,s,test,time,ts,v,dv; + char str2[15]; + FILE *out; + +/* va avec htoh2 */ + double dyh,dyh2; + +/* va avec aer */ + double dyc2h2,dyhc3n,dyhcn,dynccn,dych3cn,dyc2h3cn; + double **k_dep,**faer; + double *productaer,*csurn,*csurh,*mmolaer; + + if( (*aerprod) == 1 ) + { + k_dep = dm2d( 1, 5, 1, 3 ); /* k en s-1, reactions d'initiation */ + faer = dm2d( 1, 5, 1, 3 ); /* fraction de chaque compose */ + productaer = dm1d( 0, 3 ); /* local production rate by pathways */ + mmolaer = dm1d( 0, 3 ); /* local molar mass by pathways */ + csurn = dm1d( 0, 3 ); /* local C/N by pathways */ + csurh = dm1d( 0, 3 ); /* local C/H by pathways */ + } + +/* DEBUG */ + printf("CHIMIE: lat=%d\n",(*LAT)+1); +/**/ + + for( i = 0; i <= NC; i++) + { + strcpy( corps[i], CORPS[i] ); + corps[i][strcspn(CORPS[i], " ")] = '\0'; + } + + strcpy( outlog, "chimietitan" ); + strcat( outlog, ".log" ); + out = fopen( outlog, "w" ); + fprintf(out,"CHIMIE: lat=%d\n",(*LAT)+1); + fclose( out ); + + deltamax = 1.e5; + test = 1.0e-15; + +/* valeur de r: +r = g0 R0^2 / R * 2 * 1E-3 +avec g0 en cm/s2, R0 en km, mu et mass en g +*/ + r = 21.595656e0; + +/* DEBUG + out = fopen( outlog, "a" ); + fprintf(out,"CHIMIE: lat=%d\n",(*LAT)+1); + fclose( out ); +*/ + fl = dm1d( 0, NC-1 ); + fp = dm1d( 0, NC-1 ); + mu = dm1d( 0, NLEV-1 ); + ym1 = dm2d( 0, NC-1, 0, NLEV-1 ); + f = dm2d( 0, NC-1, 0, NLEV-1 ); + jac = dm2d( 0, NC-1, 0, NC-1 ); + c = dm2d( 0, NLEV-1, 0, NC-1 ); + a = dm3d( 0, NLEV-1, 0, NC-1, 0, NC-1 ); + b = dm3d( 0, NLEV-1, 0, NC-1, 1, 2 ); + +/* DEBUG */ +/* + out = fopen( "err.log", "a" ); + fprintf( out,"%s\n", ); + fclose( out ); +*/ + +/* initialisation mu, CH4 au sol */ + + for( j = 0; j <= NLEV-1; j++ ) + { + mu[j] = 0.0e0; + for( i = 0; i <= ST-1; i++ ) + { + if( ( strcmp(corps[i], "CH4") == 0 ) && ( Y[i][j] <= *botCH4 ) && ( j == 0 ) ) + { + fluxCH4 = (*botCH4 - Y[i][j]); + Y[i][j] = *botCH4; + } + mu[j] += ( MASS[i] * Y[i][j] ); + } + } + +/* initialisation compo avant calcul */ + for( j = NLEV-1; j >= 0; j-- ) + for( i = 0; i <= ST-1; i++ ) ym1[i][j] = max(Y[i][j],1.e-30); + +/* +========================================================================== + STRATEGIE: + INVERSION COMPLETE AVEC DIFFUSION ENTRE NLEV-1 et NLD + PUIS INVERSION LOCALE PAR BLOC ENTRE NLD ET LA SURFACE +========================================================================== + +PREMIERE ETAPE: +=============== + INVERSION COMPLETE AVEC DIFFUSION ENTRE NLEV-1 et NLD +=============== +*/ + +/* ****************** */ +/* Time loop: */ +/* ****************** */ + +time = ts = 0.0e0; +delta = 1.e-3; + +while( time < (*FIN) ) +{ + + +/* DEBUG + for( j = NLEV-1; j >= NLD; j-- ) + { + out = fopen( outlog, "a" ); + fprintf(out,"j=%d z=%e nb=%e T=%e\n",j,(RA[j]-R0),NB[j],TEMP[j]); + fclose( out ); + + out = fopen( "profils.log", "a" ); + fprintf(out,"%d %e %e %e\n",j,(RA[j]-R0),NB[j],TEMP[j]); + for (i=0;i<=NREAC-1;i++) fprintf(out,"%d %e\n",i,KRATE[i][j]); + for (i=0;i<=ST-1;i++) fprintf(out,"%10s %e\n",corps[i],Y[i][j]); + fclose( out ); + } + exit(0); +*/ + + +/* ------------------------------ */ +/* Calculs variations et jacobien */ +/* ------------------------------ */ + + for( j = NLEV-1; j >= NLD; j-- ) + { + +/* init of step */ +/* ------------ */ + for( i = 0; i <= ST-1; i++ ) + { + fp[i] = fl[i] = 0.0e0; + for( l = 0; l <= ST-1; l++ ) jac[i][l] = 0.0e0; + } + +/* Chimie */ +/* ------ */ + +/* productions et pertes chimiques */ + for( i = 0; i <= ST-1; i++ ) + { + Y[i][j] = max(Y[i][j],1.e-30); /* minimum */ + + for( l = 0; l <= nom_prod[i]-1; l++ ) /* Production term */ + { + ireac = prod[i][l]; /* Number of the reaction involves. */ + ncom1 = reactif[ireac][0]; /* First compound which reacts. */ + if( reactif[ireac][1] == NC ) /* Photodissociation or relaxation */ + { + jac[i][ncom1] += ( KRATE[ireac][j] * NB[j] ); + fp[i] += ( KRATE[ireac][j] * NB[j] * Y[ncom1][j] ); + } + else /* General case. */ + { + ncom2 = reactif[ireac][1]; /* Second compound which reacts. */ + jac[i][ncom1] += ( KRATE[ireac][j] * Y[ncom2][j] ); /* Jacobian compound #1. */ + jac[i][ncom2] += ( KRATE[ireac][j] * Y[ncom1][j] ); /* Jacobian compound #2. */ + fp[i] += ( KRATE[ireac][j] * Y[ncom1][j] * Y[ncom2][j] ); /* Production term. */ + } + } + + for( l = 0; l <= nom_perte[i]-1; l++ ) /* Loss term. */ + { + ireac = perte[i][l][0]; /* Reaction number. */ + ncom2 = perte[i][l][1]; /* Compound #2 reacts. */ + if( reactif[ireac][1] == NC ) /* Photodissociation or relaxation */ + { + jac[i][i] -= ( KRATE[ireac][j] * NB[j] ); + fl[i] += ( KRATE[ireac][j] * NB[j] ); + } + else /* General case. */ + { + jac[i][ncom2] -= ( KRATE[ireac][j] * Y[i][j] ); /* Jacobian compound #1. */ + jac[i][i] -= ( KRATE[ireac][j] * Y[ncom2][j] ); /* Jacobien compound #2. */ + fl[i] += ( KRATE[ireac][j] * Y[ncom2][j] ); /* Loss term. */ + } + } + } + + +/* Aerosols */ +/* -------- */ + if( (*aerprod) == 1 ) + { + aer(corps,TEMP,NB,Y,&j,k_dep,faer, + &dyc2h2,&dyhc3n,&dyhcn,&dynccn,&dych3cn,&dyc2h3cn,utilaer, + mmolaer,productaer,csurn,csurh); + + for( i = 0; i <= 3; i++ ) + { + PRODAER[i][j] = productaer[i]; + MAER[i][j] = mmolaer[i]; + CSN[i][j] = csurn[i]; + CSH[i][j] = csurh[i]; + } +/* DEBUG +printf("AERPROD : LAT = %d - J = %d\n",(*LAT),j); +if(fabs(dyc2h2*NB[j])>fabs(fp[utilaer[2]]/10.)) + printf("fp(%s) =%e; dyc2h2 =%e\n",corps[utilaer[2]], + fp[utilaer[2]],dyc2h2*NB[j]); +if(fabs(dyhcn*NB[j])>fabs(fp[utilaer[5]]/10.)) + printf("fp(%s) =%e; dyhcn =%e\n",corps[utilaer[5]], + fp[utilaer[5]],dyhcn*NB[j]); +if(fabs(dyhc3n*NB[j])>fabs(fp[utilaer[6]]/10.)) + printf("fp(%s) =%e; dyhc3n =%e\n",corps[utilaer[6]], + fp[utilaer[6]],dyhc3n*NB[j]); +if(fabs(dynccn*NB[j])>fabs(fp[utilaer[13]]/10.)) + printf("fp(%s) =%e; dynccn =%e\n",corps[utilaer[13]], + fp[utilaer[13]],dynccn*NB[j]); +if(fabs(dych3cn*NB[j])>fabs(fp[utilaer[14]]/10.)) + printf("fp(%s) =%e; dych3cn=%e\n",corps[utilaer[14]], + fp[utilaer[14]],dych3cn*NB[j]); +if(fabs(dyc2h3cn*NB[j])>fabs(fp[utilaer[15]]/10.)) + printf("fp(%s) =%e; dyc2h3cn=%e\n",corps[utilaer[15]], + fp[utilaer[15]],dyc2h3cn*NB[j]); +*/ + + fp[utilaer[2]] -= ( dyc2h2 * NB[j] ); + fp[utilaer[5]] -= ( dyhcn * NB[j] ); + fp[utilaer[6]] -= ( dyhc3n * NB[j] ); + fp[utilaer[13]]-= ( dynccn * NB[j] ); + fp[utilaer[14]]-= ( dych3cn * NB[j] ); + fp[utilaer[15]]-= ( dyc2h3cn * NB[j] ); + if( Y[utilaer[2]][j] != 0.0 ) + jac[utilaer[2]][utilaer[2]] -= ( dyc2h2 * NB[j] / Y[utilaer[2]][j] ); + if( Y[utilaer[5]][j] != 0.0 ) + jac[utilaer[5]][utilaer[5]] -= ( dyhcn * NB[j] / Y[utilaer[5]][j] ); + if( Y[utilaer[6]][j] != 0.0 ) + jac[utilaer[6]][utilaer[6]] -= ( dyhc3n * NB[j] / Y[utilaer[6]][j] ); + if( Y[utilaer[13]][j] != 0.0 ) + jac[utilaer[13]][utilaer[13]] -= ( dynccn * NB[j] / Y[utilaer[13]][j] ); + if( Y[utilaer[14]][j] != 0.0 ) + jac[utilaer[14]][utilaer[14]] -= ( dych3cn * NB[j] / Y[utilaer[14]][j] ); + if( Y[utilaer[15]][j] != 0.0 ) + jac[utilaer[15]][utilaer[15]] -= (dyc2h3cn * NB[j] / Y[utilaer[15]][j] ); + } + + +/* H -> H2 on haze particles */ +/* ------------------------- */ + if( (*htoh2) == 1 ) + { + heterohtoh2(corps,TEMP,NB,Y,surfhaze,&j,&dyh,&dyh2,utilaer); +/* dyh <= 0 / 1.0 en adsor., 1 en reac. */ + +/* DEBUG +printf("HTOH2 : LAT = %d - J = %d\n",(*LAT),j); +if(fabs(dyh*NB[j])>fabs(fp[utilaer[0]]/10.)) +printf("fp(%s) = %e; dyh = %e\n",corps[utilaer[0]],fp[utilaer[0]],dyh*NB[j]); +if(fabs(dyh2*NB[j])>fabs(fp[utilaer[1]]/10.)) +printf("fp(%s) = %e; dyh2 = %e\n",corps[utilaer[1]],fp[utilaer[1]],dyh2*NB[j]); +*/ + + fp[utilaer[0]] += ( dyh * NB[j] ); + /* pourquoi pas *2 ?? cf gptit dans 2da... */ + + fp[utilaer[1]] += ( dyh2 * NB[j] ); + if( Y[utilaer[0]][j] != 0.0 ) + jac[utilaer[0]][utilaer[0]] += ( dyh * NB[j] / Y[utilaer[0]][j] ); + /* pourquoi pas *2 ?? cf gptit dans 2da... */ + } + + +/* Backup jacobian level j. */ +/* ------------------------ */ + for( i = 0; i <= ST-1; i++ ) + for( k = 0; k <= ST-1; k++ ) + a[j][i][k] = jac[i][k]; + + +/* Diffusion verticale et flux exterieurs */ +/* -------------------------------------- */ + +/* +pour dy/dr, dr doit etre en cm... +pareil pour dphi/dr +*/ + for( i = 0; i <= ST-1; i++ ) + { + +/* First level. */ + if( j == NLD ) + { + v = dv = 0.0e0; + dra = RA[j+1]-RA[j]; + + cp = (NB[j+1]+NB[j])/2.; /* Mean total concentration. */ + dip = r * (MASS[i]-(mu[j+1]+mu[j])/2.) / (TEMP[j+1]+TEMP[j]) / + pow( RA[j+1], 2.0e0 ); /* Delta i,j level +1. */ + dp = (MD[i][j]+MD[i][j+1])/2.; /* Mean molecular diffusion. */ + dyp = (Y[i][j+1]-Y[i][j])/(RA[j+2]-RA[j])*2.e-5; /* Delta y level +1. */ + kp = (KEDD[j+1]+KEDD[j])/2.; /* Mean eddy diffusion. */ + /* div phi. */ + f[i][j] = cp * ( dp * ( (Y[i][j+1]+Y[i][j])/2. * dip + dyp ) + + kp * dyp ) + * (4.e-5/dra/pow((1.+RA[j]/RA[j+1]),2.)) + + fp[i] - Y[i][j]*fl[i] + v; + /* dphi / dy this level. */ + a[j][i][i] += ( cp * ( dp * 0.5e0 * dip + - 2.e-5/(RA[j+2]-RA[j]) * (dp + kp) ) + * (4.e-5/dra/pow((1.+RA[j]/RA[j+1]),2.)) + dv ); + /* dphi / dy level +1. */ + c[j][i] = -THETA * delta + * cp * ( dp * 0.5e0 * dip + + 2.e-5/(RA[j+2]-RA[j]) * (dp + kp) ) + * (4.e-5/dra/pow((1.+RA[j]/RA[j+1]),2.)); + } +/* Last level. */ + else if( j == NLEV-1 ) + { + v = dv = 0.0e0; + dra = RA[NLEV-1]-RA[NLEV-2]; + + /* Jeans escape */ + if( strcmp(corps[i], "H") == 0 ) + { + dv = top_H * NB[NLEV-1] + * (4.e-5/dra/pow((2.-dra/(RA[NLEV-1]+dra)),2.)); + v = dv * Y[i][NLEV-1]; + } + if( strcmp(corps[i], "H2") == 0 ) + { + dv = top_H2 * NB[NLEV-1] + * (4.e-5/dra/pow((2.-dra/(RA[NLEV-1]+dra)),2.)); + v = dv * Y[i][NLEV-1]; + } + /* Input flux for N(4S) */ + if( strcmp(corps[i], "N4S") == 0 ) + v = top_N4S + * (4.e-5/dra/pow((2.-dra/(RA[NLEV-1]+dra)),2.)); + + cm = (NB[NLEV-1]+NB[NLEV-2])/2.; /* Mean total concentration. */ + dim = r * (MASS[i]-(mu[NLEV-1]+mu[NLEV-2])/2.) + / (TEMP[NLEV-1]+TEMP[NLEV-2]) + / pow( RA[NLEV-1], 2.0e0 ); /* Delta i,j level -1. */ + dm = (MD[i][NLEV-1]+MD[i][NLEV-2])/2.; /* Mean molecular diffusion. */ + dym = (Y[i][NLEV-1]-Y[i][NLEV-2])/dra*1.e-5; /* Delta y level -1. */ + km = (KEDD[NLEV-1]+KEDD[NLEV-2])/2.; /* Mean eddy diffusion. */ + /* div phi. */ + f[i][NLEV-1] = fp[i] - Y[i][NLEV-1]*fl[i] - v + - cm * ( dm * ( (Y[i][NLEV-1]+Y[i][NLEV-2])/2. * dim + dym ) + + km * dym ) + * (4.e-5/dra/pow((2.+dra/RA[NLEV-1]),2.)); + /* dphi / dy this level */ + a[NLEV-1][i][i] -= ( cm * ( dm * 0.5e0 * dim + + 1.e-5/dra * (dm + km ) ) + * (4.e-5/dra/pow((2.+dra/RA[NLEV-1]),2.)) + dv ); + /* dphi / dy level -1. */ + b[NLEV-1][i][2] = THETA * delta + * cm * ( dm * 0.5e0 * dim + - 1.e-5/dra * (dm + km ) ) + * (4.e-5/dra/pow((2.+dra/RA[NLEV-1]),2.)); + } + else + { + v = dv = 0.0e0; + dram=(RA[j+1]-RA[j-1])/2.; + if (j= NLD; j-- ) + { + if( j != NLEV-1 ) + for( i = 0; i <= ST-1; i++ ) f[i][j] -= ( c[j][i] * b[j+1][i][1] ); + for( i = 0; i <= ST-1; i++ ) + { + s = 0.0e0; + for( k = 0; k <= ST-1; k++ ) s += ( a[j][i][k] * f[k][j] ); + b[j][i][1] = s; + Y[i][j] += s; + if( Y[i][j] <= 1.0e-30 ) Y[i][j] = 0.0e0; + } + } + +/* ------------------ */ +/* Tests et evolution */ +/* ------------------ */ + +/* Calcul deviation */ +/* ---------------- */ + + for( j = NLD; j <= NLEV-1; j++ ) + for( i = 0; i <= ST-1; i++ ) + if( ( Y[i][j] > test ) && ( ym1[i][j] > test ) ) + { + conv = fabs( Y[i][j] - ym1[i][j] ) / ym1[i][j]; + if( conv > ts ) + { +/* + if( conv >= 0.1 ) + { + out = fopen( outlog, "a" ); + fprintf( out, "Lat no %d;", (*LAT)+1); + fprintf(out, " alt:%e; %s %e %e ; %e %e\n",(RA[j]-R0),corps[i],ym1[i],Y[i][j],time,delta); + fclose( out ); + } +*/ + ts = conv; + } + } + +/* test deviation */ +/* -------------- */ + + if( ts < 0.1e0 ) + { + for( i = 0; i <= ST-1; i++ ) + for( j = NLD; j <= NLEV-1; j++ ) + if( (Y[i][j] >= 0.5e0) && (strcmp(corps[i],"N2") != 0) ) + { + out = fopen( outlog, "a" ); + fprintf( out, "WARNING %s mixing ratio is %e %e at %d\n", + corps[i], ym1[i], Y[i][j], j ); + for( k = 0; k <= NLEV-1; k++ ) fprintf( out, "%d %e %e\n",k,ym1[i],Y[i][k] ); + fclose( out ); + exit(0); +// Y[i][j] = 1.e-20; + } + for( j = NLD; j <= NLEV-1; j++ ) + for( i = 0; i <= NC-1; i++ ) ym1[i][j] = max(Y[i][j],1.e-30); + time += delta; + if( ts < 1.00e-5 ) delta *= 1.0e2; + if( ( ts > 1.00e-5 ) && ( ts < 1.0e-4 ) ) delta *= 1.0e1; + if( ( ts > 1.00e-4 ) && ( ts < 1.0e-3 ) ) delta *= 5.0e0; + if( ( ts > 1.00e-3 ) && ( ts < 5.0e-3 ) ) delta *= 3.0e0; + if( ( ts > 5.00e-3 ) && ( ts < 0.01e0 ) ) delta *= 1.5e0; + if( ( ts > 0.010e0 ) && ( ts < 0.03e0 ) ) delta *= 1.2e0; + if( ( ts > 0.030e0 ) && ( ts < 0.05e0 ) ) delta *= 1.1e0; + +// if( ( ts > 0.001e0 ) && ( ts < 0.01e0 ) ) delta *= 3.0e0; +// if( ( ts > 0.010e0 ) && ( ts < 0.05e0 ) ) delta *= 1.5e0; + + delta = min( deltamax, delta ); + } + else + { + for( j = NLD; j <= NLEV-1; j++ ) + for( i = 0; i <= NC-1; i++ ) Y[i][j] = ym1[i][j]; + + if( ts > 0.8 ) delta *= 1.e-6; + if( ( ts > 0.6 ) && ( ts <= 0.8 ) ) delta *= 1.e-4; + if( ( ts > 0.4 ) && ( ts <= 0.6 ) ) delta *= 1.e-2; + if( ( ts > 0.3 ) && ( ts <= 0.4 ) ) delta *= 0.1; + if( ( ts > 0.2 ) && ( ts <= 0.3 ) ) delta *= 0.2; + if( ( ts > 0.1 ) && ( ts <= 0.2 ) ) delta *= 0.3; + } + ts = 0.0e0; + + out = fopen( outlog, "a" ); + fprintf(out, "delta:%e; time:%e; fin:%e\n",delta,time,(*FIN)); + fclose( out ); + +} +/* **************** */ +/* end of time loop */ +/* **************** */ + +/* +========================================================================== + +SECONDE ETAPE: +=============== + INVERSION LOCALE PAR BLOC ENTRE NLD ET LA SURFACE +=============== +*/ + if( NLD != 0 ) + for( j = NLD-1; j >= 0; j-- ) + { + time = ts = 0.0e0; + delta = 1.e-3; + +/* ++++++++++++ */ +/* time loop. */ +/* ++++++++++++ */ + + while( time < (*FIN) ) + { + +/* init of step */ +/* ------------ */ + for( i = 0; i <= ST-1; i++ ) + { + fp[i] = fl[i] = 0.0e0; + for( l = 0; l <= ST-1; l++ ) jac[i][l] = 0.0e0; + } + +/* Chimie */ +/* ------ */ + +/* productions et pertes chimiques */ + for( i = 0; i <= ST-1; i++ ) + { + Y[i][j] = max(Y[i][j],1.e-30); /* minimum */ + + for( l = 0; l <= nom_prod[i]-1; l++ ) /* Production term */ + { + ireac = prod[i][l]; /* Number of the reaction involves. */ + ncom1 = reactif[ireac][0]; /* First compound which reacts. */ + if( reactif[ireac][1] == NC ) /* Photodissociation or relaxation */ + { + jac[i][ncom1] += ( KRATE[ireac][j] * NB[j] ); + fp[i] += ( KRATE[ireac][j] * NB[j] * Y[ncom1][j] ); + } + else /* General case. */ + { + ncom2 = reactif[ireac][1]; /* Second compound which reacts. */ + jac[i][ncom1] += ( KRATE[ireac][j] * Y[ncom2][j] ); /* Jacobian compound #1. */ + jac[i][ncom2] += ( KRATE[ireac][j] * Y[ncom1][j] ); /* Jacobian compound #2. */ + fp[i] += ( KRATE[ireac][j] * Y[ncom1][j] * Y[ncom2][j] ); /* Production term. */ + } + } + + for( l = 0; l <= nom_perte[i]-1; l++ ) /* Loss term. */ + { + ireac = perte[i][l][0]; /* Reaction number. */ + ncom2 = perte[i][l][1]; /* Compound #2 reacts. */ + if( reactif[ireac][1] == NC ) /* Photodissociation or relaxation */ + { + jac[i][i] -= ( KRATE[ireac][j] * NB[j] ); + fl[i] += ( KRATE[ireac][j] * NB[j] ); + } + else /* General case. */ + { + jac[i][ncom2] -= ( KRATE[ireac][j] * Y[i][j] ); /* Jacobian compound #1. */ + jac[i][i] -= ( KRATE[ireac][j] * Y[ncom2][j] ); /* Jacobien compound #2. */ + fl[i] += ( KRATE[ireac][j] * Y[ncom2][j] ); /* Loss term. */ + } + } + } + + +/* Aerosols */ +/* -------- */ + if( (*aerprod) == 1 ) + { + aer(corps,TEMP,NB,Y,&j,k_dep,faer, + &dyc2h2,&dyhc3n,&dyhcn,&dynccn,&dych3cn,&dyc2h3cn,utilaer, + mmolaer,productaer,csurn,csurh); + + for( i = 0; i <= 3; i++ ) + { + PRODAER[i][j] = productaer[i]; + MAER[i][j] = mmolaer[i]; + CSN[i][j] = csurn[i]; + CSH[i][j] = csurh[i]; + } +/* DEBUG +printf("AERPROD : LAT = %d - J = %d\n",(*LAT),j); +if(fabs(dyc2h2*NB[j])>fabs(fp[utilaer[2]]/10.)) + printf("fp(%s) =%e; dyc2h2 =%e\n",corps[utilaer[2]], + fp[utilaer[2]],dyc2h2*NB[j]); +if(fabs(dyhcn*NB[j])>fabs(fp[utilaer[5]]/10.)) + printf("fp(%s) =%e; dyhcn =%e\n",corps[utilaer[5]], + fp[utilaer[5]],dyhcn*NB[j]); +if(fabs(dyhc3n*NB[j])>fabs(fp[utilaer[6]]/10.)) + printf("fp(%s) =%e; dyhc3n =%e\n",corps[utilaer[6]], + fp[utilaer[6]],dyhc3n*NB[j]); +if(fabs(dynccn*NB[j])>fabs(fp[utilaer[13]]/10.)) + printf("fp(%s) =%e; dynccn =%e\n",corps[utilaer[13]], + fp[utilaer[13]],dynccn*NB[j]); +if(fabs(dych3cn*NB[j])>fabs(fp[utilaer[14]]/10.)) + printf("fp(%s) =%e; dych3cn=%e\n",corps[utilaer[14]], + fp[utilaer[14]],dych3cn*NB[j]); +if(fabs(dyc2h3cn*NB[j])>fabs(fp[utilaer[15]]/10.)) + printf("fp(%s) =%e; dyc2h3cn=%e\n",corps[utilaer[15]], + fp[utilaer[15]],dyc2h3cn*NB[j]); +*/ + + fp[utilaer[2]] -= ( dyc2h2 * NB[j] ); + fp[utilaer[5]] -= ( dyhcn * NB[j] ); + fp[utilaer[6]] -= ( dyhc3n * NB[j] ); + fp[utilaer[13]]-= ( dynccn * NB[j] ); + fp[utilaer[14]]-= ( dych3cn * NB[j] ); + fp[utilaer[15]]-= ( dyc2h3cn * NB[j] ); + if( Y[utilaer[2]][j] != 0.0 ) + jac[utilaer[2]][utilaer[2]] -= ( dyc2h2 * NB[j] / Y[utilaer[2]][j] ); + if( Y[utilaer[5]][j] != 0.0 ) + jac[utilaer[5]][utilaer[5]] -= ( dyhcn * NB[j] / Y[utilaer[5]][j] ); + if( Y[utilaer[6]][j] != 0.0 ) + jac[utilaer[6]][utilaer[6]] -= ( dyhc3n * NB[j] / Y[utilaer[6]][j] ); + if( Y[utilaer[13]][j] != 0.0 ) + jac[utilaer[13]][utilaer[13]] -= ( dynccn * NB[j] / Y[utilaer[13]][j] ); + if( Y[utilaer[14]][j] != 0.0 ) + jac[utilaer[14]][utilaer[14]] -= ( dych3cn * NB[j] / Y[utilaer[14]][j] ); + if( Y[utilaer[15]][j] != 0.0 ) + jac[utilaer[15]][utilaer[15]] -= (dyc2h3cn * NB[j] / Y[utilaer[15]][j] ); + } + + +/* H -> H2 on haze particles */ +/* ------------------------- */ + if( (*htoh2) == 1 ) + { + heterohtoh2(corps,TEMP,NB,Y,surfhaze,&j,&dyh,&dyh2,utilaer); +/* dyh <= 0 / 1.0 en adsor., 1 en reac. */ + +/* DEBUG +printf("HTOH2 : LAT = %d - J = %d\n",(*LAT),j); +if(fabs(dyh*NB[j])>fabs(fp[utilaer[0]]/10.)) +printf("fp(%s) = %e; dyh = %e\n",corps[utilaer[0]],fp[utilaer[0]],dyh*NB[j]); +if(fabs(dyh2*NB[j])>fabs(fp[utilaer[1]]/10.)) +printf("fp(%s) = %e; dyh2 = %e\n",corps[utilaer[1]],fp[utilaer[1]],dyh2*NB[j]); +*/ + + fp[utilaer[0]] += ( dyh * NB[j] ); + /* pourquoi pas *2 ?? cf gptit dans 2da... */ + + fp[utilaer[1]] += ( dyh2 * NB[j] ); + if( Y[utilaer[0]][j] != 0.0 ) + jac[utilaer[0]][utilaer[0]] += ( dyh * NB[j] / Y[utilaer[0]][j] ); + /* pourquoi pas *2 ?? cf gptit dans 2da... */ + } + + +/* Backup jacobian level j. */ +/* ------------------------ */ + for( i = 0; i <= ST-1; i++ ) + { + for( k = 0; k <= ST-1; k++ ) + a[j][i][k] = jac[i][k]; + f[i][j] = fp[i] - fl[i] * Y[i][j]; + } + + +/* finition pour inversion */ +/* ----------------------- */ + + for( i = 0; i <= ST-1; i++ ) + { + for( k = 0; k <= ST-1; k++ ) + { + a[j][i][k] *= ( -THETA * delta ); /* Correction time step. */ + if( k == i ) a[j][k][k] += NB[j]; /* Correction diagonal. */ + } + f[i][j] *= delta; + } + + +/* Inversion of matrix cf method LU */ +/* -------------------------------- */ + +/* inversion by blocs: */ +/* Hydrocarbons */ + + solve_b( a, f, j, 0, NHC-1 ); + for( i = 0; i <= NHC-1; i++ ) + { + Y[i][j] += f[i][j]; + if( Y[i][j] <= 1.0e-30 ) Y[i][j] = 0.0e0; + } + +/* Nitriles */ + + solve_b( a, f, j, NHC, ST-1 ); + for( i = NHC+1; i <= ST-1; i++ ) + { + Y[i][j] += f[i][j]; + if( Y[i][j] <= 1.0e-30 ) Y[i][j] = 0.0e0; + } + +/* end inversion by blocs: */ + +/* CH4 au sol */ +/* ---------- */ + for( i = 0; i <= ST-1; i++ ) + if( ( strcmp(corps[i], "CH4") == 0 ) && (j==0) && ( Y[i][0] < *botCH4 ) ) + { + fluxCH4 += (*botCH4 - Y[i][0]); + Y[i][0] = *botCH4; + } + +/* ------------------ */ +/* Tests et evolution */ +/* ------------------ */ + +/* Calcul deviation */ +/* ---------------- */ + + for( i = 0; i <= ST-1; i++ ) + { + test = 1.0e-15; + if( ( Y[i][j] > test ) && ( ym1[i][j] > test ) ) + { + conv = fabs( Y[i][j] - ym1[i][j] ) / ym1[i][j]; + + if( conv > ts ) + { +/* + if( conv >= 0.1 ) + { + out = fopen( outlog, "a" ); + fprintf( out, "Lat no %d; declin:%e;", (*LAT)+1, (*DECLIN) ); + fprintf(out, " alt:%e; %s %e %e ; %e %e\n",(RA[j]-R0),corps[i],ym1[i],Y[i][j],time,delta); + fclose( out ); + } +*/ + ts = conv; + } + } + } + +/* test deviation */ +/* -------------- */ + + if( ts < 0.1e0 ) + { + for( i = 0; i <= ST-1; i++ ) + if( (Y[i][j] >= 0.5e0) && (strcmp(corps[i],"N2") != 0) ) + { + out = fopen( outlog, "a" ); + fprintf( out, "WARNING %s mixing ratio is %e %e at %d\n", + corps[i], ym1[i][j], Y[i][j], j ); + for( k = 0; k <= NLEV-1; k++ ) fprintf( out, "%d %e %e\n",k,ym1[i][j],Y[i][k] ); + fclose( out ); + // exit(0); + Y[i][j] = 1.e-20; + } + for( i = 0; i <= NC-1; i++ ) ym1[i][j] = max(Y[i][j],1.e-30); + time += delta; + if( ts < 1.00e-5 ) delta *= 1.0e2; + if( ( ts > 1.00e-5 ) && ( ts < 1.0e-4 ) ) delta *= 1.0e1; + if( ( ts > 1.00e-4 ) && ( ts < 1.0e-3 ) ) delta *= 5.0e0; + if( ( ts > 0.001e0 ) && ( ts < 0.01e0 ) ) delta *= 3.0e0; + if( ( ts > 0.010e0 ) && ( ts < 0.05e0 ) ) delta *= 1.5e0; + + delta = min( deltamax, delta ); + } + else + { + for( i = 0; i <= NC-1; i++ ) Y[i][j] = ym1[i][j]; + + if( ts > 0.8 ) delta *= 1.e-6; + if( ( ts > 0.6 ) && ( ts <= 0.8 ) ) delta *= 1.e-4; + if( ( ts > 0.4 ) && ( ts <= 0.6 ) ) delta *= 1.e-2; + if( ( ts > 0.3 ) && ( ts <= 0.4 ) ) delta *= 0.1; + if( ( ts > 0.2 ) && ( ts <= 0.3 ) ) delta *= 0.2; + if( ( ts > 0.1 ) && ( ts <= 0.2 ) ) delta *= 0.3; + } + ts = 0.0e0; +/* + out = fopen( outlog, "a" ); + fprintf(out, " alt:%e; delta:%e; time:%e; fin:%e\n",(RA[j]-R0),delta,time,(*FIN)); + fclose( out ); +*/ + } + +/* +++++++++++++++++++ */ +/* end of time loop. */ +/* +++++++++++++++++++ */ + + for( i = 0; i <= ST-1; i++ ) + if( ( strcmp(corps[i],"CH4") == 0 ) && ( j == 0 ) ) + fluxCH4 *= ( MASS[i]/(6.022e23*time) ); + + } /* boucle j */ + + +/* +========================================================================== + +FINALISATION: +=============== +*/ + for( i = 0; i <= ST-1; i++ ) + if( strcmp(corps[i],"CH4") == 0 ) + fluxCH4 *= ( MASS[i]/(6.022e23*time) ); + +/* Niveau de N2 */ +/* ------------ */ + + for( j = 0; j <= NLEV-1; j++ ) + { + conv = 0.0e0; + for( i = 0; i <= ST-1; i++ ) + if( strcmp(corps[i],"N2") != 0 ) conv += Y[i][j]; + for( i = 0; i <= ST-1; i++ ) + if( strcmp(corps[i],"N2") == 0 ) Y[i][j] = 1. - conv; + } + + if( (*aerprod) == 1 ) + { + fdm2d( k_dep, 1, 5, 1 ); + fdm2d( faer, 1, 5, 1 ); + fdm1d( productaer, 0 ); + fdm1d( mmolaer, 0 ); + fdm1d( csurn, 0 ); + fdm1d( csurh, 0 ); + } + + fdm1d( fl, 0 ); + fdm1d( fp, 0 ); + fdm1d( mu, 0 ); + fdm2d( ym1, 0, NC-1, 0 ); + fdm2d( f, 0, NC-1, 0 ); + fdm2d( jac, 0, NC-1, 0 ); + fdm2d( c, 0, NLEV-1, 0 ); + fdm3d( a, 0, NLEV-1, 0, NC-1, 0 ); + fdm3d( b, 0, NLEV-1, 0, NC-1, 1 ); +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/htoh2.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/htoh2.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/htoh2.c (revision 1643) @@ -0,0 +1,62 @@ +/* htoh2: production of H2 from heterogenous recombination of H + on the haze particles */ + +#include "titan.h" + +void heterohtoh2( char corps[][10], double *tp, double *nb, double y[][NLEV], + double *sh, int *zj, + double *out1, double *out2, int *utilaer ) +{ + int z; + int i,j,h,h2; + double dy_h2,dy_h,nbCsites; + double surfhaze,temp,ct; + + z = (*zj); + temp = tp[z]; + ct = nb[z]; + surfhaze = sh[z]; + +/* composes interessants */ +/* --------------------- */ +/* !! decalage de 1 par rapport a calchim !! */ + + h = utilaer[0]; + h2 = utilaer[1]; + +/* nbCsites: total nb of C sites */ +/* ----------------------------- */ + +/* HYPOTHESE POUR LA TAILLE DU SITE D'UN C */ + +/* 2e-9*4pi = 2.5e-8 = surface (um2) d'1 C + en supposant un disque PAH (correspond a un rayon de 0.9AA) */ + + nbCsites = surfhaze / 2.5e-8; + +/* taux de recombinaison */ +/* --------------------- */ + +/* H + bounded H -> H2 */ + + dy_h2 = y[h][z] + * 1.58e4 * sqrt(temp) /* kinetic speed of H atoms (cm s-1) */ + * nbCsites /* haze: total nb of C sites (cm-3) */ + * 1.8e-18*exp(-300/temp); /* X-section Y.Sekine (cm2) */ +// * 1.e-15*exp(-1700/temp); /* X-section for bounded H atoms (cm2) */ + + dy_h = -dy_h2; + +/* H + surface -> bounded H */ + + if(1==1) // si faux, surface saturee + dy_h = dy_h - y[h][z] + * 1.58e4 * sqrt(temp) /* kinetic speed of H atoms (cm s-1) */ + * nbCsites /* haze: total nb of C sites (cm-3) */ + * 8.8e-16*exp(-1100/temp); /* Xsection Y.Sekine (cm2) */ +// * 1.e-15*exp(-1700/temp); /* X-section for bounded H atoms (cm2) */ + + *out1 = dy_h; + *out2 = dy_h2; +} + Index: trunk/LMDZ.TITAN.old/libf/chimtitan/omega.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/omega.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/omega.c (revision 1643) @@ -0,0 +1,14 @@ +/* omega: correction to perfect gas compound */ +/* 30 Oct 96 */ + +#include "titan.h" + +double omega( ts, epsa, epsb ) +double epsa,epsb,ts; +{ + double t; + + t = ts / sqrt( epsa * epsb ); + return 1.06036e0 * pow( t, -0.1561e0 ) + 0.193e0 * exp( -0.47635e0 * t ) + + 1.03587e0 * exp( -1.52996e0 * t ) + 1.76474e0 * exp( -3.89411e0 * t ); +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/solve.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/solve.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/solve.c (revision 1643) @@ -0,0 +1,136 @@ +/* matrix inversion */ +/* cf Numerical Recipes LU Method for equations numbers */ +/* GCCM */ +/* similaire a inv (GP) */ +/* la matrice a est inversee seulement sur le bloc [n0;n1][n0;n1] */ + +#include "titan.h" + +void solve( double ***aa, int m, int n0, int n1 ) +{ + int i,ii,imax,j,k,l,ll; + double **a,aamax,dum,*indx,sum,**vv,tmp; + FILE *out; + + indx = dm1d( n0, n1 ); + vv = dm2d( n0, n1, n0, n1 ); + a = dm2d( n0, n1, n0, n1 ); + imax = n0; + + for( i = n0; i <= n1; i++ ) for( j = n0; j <= n1; j++ ) a[i][j]=aa[m][i][j]; + + for( i = n0; i <= n1; i++ ) + { + aamax = 0.0e0; + for( k = n0; k <= n1; k++ ) + if( (tmp=fabs(a[i][k])) > aamax ) aamax = tmp; + if( aamax < 1.0e-20 ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Singular matrix. n0=%ld k=%ld aamax=%le\n", + n0,k,aamax); + fclose( out ); + exit(0); +/* aamax = 1.e-30; */ + } + vv[i][1] = 1.0e0 / aamax; /* Save the scaling */ +/* + if( (aamax > 1.0e100)||(aamax < 1.0e-100) ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "ATTENTION aamax = %le\n", aamax ); + fclose( out ); + exit( 0 ); + } +*/ + } + for( k = n0; k <= n1; k++ ) + { + for( i = n0; i < k; i++ ) /* This is equation 2.3.12 except for i = j */ + { + sum = a[i][k]; + for( l = n0; l < i; l++ ) + sum -= ( a[i][l] * a[l][k] ); + a[i][k] = sum; + } + aamax = 0.0e0; /* Initialize for the search for largest pivot element */ + for( i = k; i <= n1; i++ ) /* This is i = j of equation 2.3.12 and */ + { + sum = a[i][k]; /* i = J + 1,...,N of equation 2.3.13 */ + for( l = n0; l < k; l++ ) + sum -= ( a[i][l] * a[l][k] ); + a[i][k] = sum; + dum = vv[i][1] * fabs(sum); /* Figure of merit for the pivot */ + if( dum >= aamax ) /* Is it better than the best so far ? */ + { + imax = i; + aamax = dum; + } + } + if( k != imax ) /* Do we need to interchange rows ? */ + { + for( l = n0; l <= n1; l++ ) /* Yes, do so... */ + { + dum = a[imax][l]; + a[imax][l] = a[k][l]; + a[k][l] = dum; + } + vv[imax][1] = vv[k][1]; /* Also interchange the scale factor */ + } + indx[k] = imax; + if( fabs(a[k][k]) < 1.0e-20 ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Pivot too small. n0=%ld k=%ld fabs(a[k][k])=%le\n", + n0,k,fabs(a[k][k]) ); + fclose( out ); + exit(0); +/* a[k][k] = 1.e-20; */ + } + if( k != n1 ) /* If the pivot element is less than 1.0d-20 we */ + { /* assume that the matrix is singular */ + dum = a[k][k]; /* ( at least to the precision of the algorithm and the machine ) */ + for( i = k+1; i <= n1; i++ ) /* Now, finally devide by the pivot element */ + a[i][k] /= dum; + } + } /* Go back to the next column in the reduction */ + + for( i = n0; i <= n1; i++ ) + { + for( k = n0; k <= n1; k++ ) + vv[i][k] = 0.0e0; + vv[i][i] = 1.0e0; + } + + for( l = n0; l <= n1; l++ ) + { + ii = n0-1; + for( i = n0; i <= n1; i++ ) + { + ll = indx[i]; + sum = vv[ll][l]; + vv[ll][l] = vv[i][l]; + if( ii != (n0-1) ) + for( k = ii; k < i; k++ ) + sum -= ( a[i][k] * vv[k][l] ); + else if( sum != 0.0e0 ) ii = i; + vv[i][l] = sum; + } + for( i = n1; i >= n0; i-- ) + { + sum = vv[i][l]; + if( i < n1 ) + for( k = i+1; k <= n1; k++ ) + sum -= ( a[i][k] * vv[k][l] ); + vv[i][l] = sum / a[i][i]; + } + } + + for( i = n0; i <= n1; i++ ) + for( l = n0; l <= n1; l++ ) + aa[m][i][l]=vv[i][l]; + + fdm1d( indx, n0 ); + fdm2d( vv, n0, n1, n0 ); + fdm2d( a, n0, n1, n0 ); +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/solve_b.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/solve_b.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/solve_b.c (revision 1643) @@ -0,0 +1,126 @@ +/* matrix inversion */ +/* cf Numerical Recipes LU Method for equations numbers */ +/* GCCM */ +/* similaire a inv (GP) */ +/* la matrice a est inversee seulement sur le bloc [n0;n1][n0;n1] */ + +#include "titan.h" + +void solve_b( double ***aa, double **f, int m, int n0, int n1 ) +{ + int i,ii,imax,j,k,l,ll; + double **a,aamax,dum,*indx,sum,*vv,tmp; + FILE *out; + + indx = dm1d( n0, n1 ); + vv = dm1d( n0, n1 ); + a = dm2d( n0, n1, n0, n1 ); + imax = n0; + + for( i = n0; i <= n1; i++ ) for( j = n0; j <= n1; j++ ) a[i][j]=aa[m][i][j]; + + for( i = n0; i <= n1; i++ ) + { + aamax = 0.0e0; + for( k = n0; k <= n1; k++ ) + if( (tmp=fabs(a[i][k])) > aamax ) aamax = tmp; + if( aamax < 1.0e-20 ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Singular matrix. n0=%ld k=%ld aamax=%le\n", + n0,k,aamax); + fclose( out ); + exit(0); +/* aamax = 1.e-30; */ + } + vv[i] = 1.0e0 / aamax; /* Save the scaling */ +/* + if( (aamax > 1.0e100)||(aamax < 1.0e-100) ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "ATTENTION aamax = %le\n", aamax ); + fclose( out ); + exit( 0 ); + } +*/ + } + for( k = n0; k <= n1; k++ ) + { + for( i = n0; i < k; i++ ) /* This is equation 2.3.12 except for i = j */ + { + sum = a[i][k]; + for( l = n0; l < i; l++ ) + sum -= ( a[i][l] * a[l][k] ); + a[i][k] = sum; + } + aamax = 0.0e0; /* Initialize for the search for largest pivot element */ + for( i = k; i <= n1; i++ ) /* This is i = j of equation 2.3.12 and */ + { + sum = a[i][k]; /* i = J + 1,...,N of equation 2.3.13 */ + for( l = n0; l < k; l++ ) + sum -= ( a[i][l] * a[l][k] ); + a[i][k] = sum; + dum = vv[i] * fabs(sum); /* Figure of merit for the pivot */ + if( dum >= aamax ) /* Is it better than the best so far ? */ + { + imax = i; + aamax = dum; + } + } + if( k != imax ) /* Do we need to interchange rows ? */ + { + for( l = n0; l <= n1; l++ ) /* Yes, do so... */ + { + dum = a[imax][l]; + a[imax][l] = a[k][l]; + a[k][l] = dum; + } + vv[imax] = vv[k]; /* Also interchange the scale factor */ + } + indx[k] = imax; + if( fabs(a[k][k]) < 1.0e-20 ) + { + out = fopen( "err.log", "a" ); + fprintf( out, "Pivot too small. n0=%ld k=%ld fabs(a[k][k])=%le\n", + n0,k,fabs(a[k][k]) ); + fclose( out ); + exit(0); +/* a[k][k] = 1.e-20; */ + } + if( k != n1 ) /* If the pivot element is less than 1.0d-20 we */ + { /* assume that the matrix is singular */ + dum = a[k][k]; /* ( at least to the precision of the algorithm and the machine ) */ + for( i = k+1; i <= n1; i++ ) /* Now, finally devide by the pivot element */ + a[i][k] /= dum; + } + } /* Go back to the next column in the reduction */ + + for( i = n0; i <= n1; i++ ) vv[i]=f[i][m]; + + ii = n0-1; + for( i = n0; i <= n1; i++ ) + { + ll = indx[i]; + sum = vv[ll]; + vv[ll] = vv[i]; + if( ii != (n0-1) ) + for( k = ii; k < i; k++ ) + sum -= ( a[i][k] * vv[k] ); + else if( sum != 0.0e0 ) ii = i; + vv[i] = sum; + } + for( i = n1; i >= n0; i-- ) + { + sum = vv[i]; + if( i < n1 ) + for( k = i+1; k <= n1; k++ ) + sum -= ( a[i][k] * vv[k] ); + vv[i] = sum / a[i][i]; + } + + for( i = n0; i <= n1; i++ ) f[i][m]=vv[i]; + + fdm1d( indx, n0 ); + fdm1d( vv, n0 ); + fdm2d( a, n0, n1, n0 ); +} Index: trunk/LMDZ.TITAN.old/libf/chimtitan/titan.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/titan.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/titan.h (revision 1643) @@ -0,0 +1,59 @@ +/* titan.h: parameters for gptitan.c */ + +#include +#include +#include +#include + +#define R0 (double)(2575.0) /* Titan's radius */ +#define NLEV (int)(125) /* Nbre de niv verticaux - =llm+70 dans common_mod */ +#define NLD (int)(40) /* Nbre de niv verticaux faits sans diff */ +#define NLRT (int)(650) /* Nbre de niv verticaux dans table fmoy - aussi dans common_mod */ + +/* fluxes at 1300 km : upward is +, downward is - */ +#define top_H (double)(+1.1e4) +#define top_H2 (double)(+3.7e3) +#define top_N4S (double)(-1.1e8) /* = -2.5e8/2.27 ... */ + +/* DEPEND DE LA VERSION CHIMIE: */ +#define VERCHIM "chimie_simpnit_051006_bis" +#define NREAC (int)(377) /* nombre de reactions - aussi dans common_mod */ +#define RDISS (int)(54) /* nombre de photodiss - aussi dans common_mod */ +#define NC (int)(44) /* nb de composes - aussi dans common_mod */ +#define ST (int)(NC) /* nb de composes inverses */ +#define NHC (int)(32) /* nb hydrocarbons */ + +#define THETA (double)(0.501) +#ifndef M_PI +#define M_PI (double)(3.14159265358979323846e0) +#endif +#define RAD (double)(M_PI / 180.0e0) +#ifndef max +#define max(a,b) ((a)>(b)?(a):(b)) +#define min(a,b) ((a)<=(b)?(a):(b)) +#endif + +void chimie_(char (*)[10], double *, double *, double (*)[NLEV], + int (*)[5], int *, int *, int (*)[200][2], int (*)[200]); +void comp_(char (*)[10], double *, double *, double *, double (*)[NLEV]); +void disso_(double (*)[NLRT][RDISS+1][15], int *); +double omega( double, double, double ); +void solve( double ***, int, int, int ); +void solve_b( double ***, double **, int, int, int ); +float *rm1d( int, int ); +float **rm2d( int, int, int, int ); +float ***rm3d( int, int, int, int, int, int ); +float ****rm4d( int, int, int, int, int, int, int, int ); +double *dm1d( int, int ); +double **dm2d( int, int, int, int ); +double ***dm3d( int, int, int, int, int, int ); +double ****dm4d( int, int, int, int, int, int, int, int ); +void frm1d( float *, int ); +void frm2d( float **, int, int, int ); +void frm3d( float ***, int, int, int, int, int ); +void fdm1d( double *, int ); +void fdm2d( double **, int, int, int ); +void fdm3d( double ***, int, int, int, int, int ); +int *im1d( int, int ); +int **im2d( int, int, int, int ); +int ***im3d( int, int, int, int, int, int ); Index: trunk/LMDZ.TITAN.old/libf/chimtitan/tractitan.c =================================================================== --- trunk/LMDZ.TITAN.old/libf/chimtitan/tractitan.c (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/chimtitan/tractitan.c (revision 1643) @@ -0,0 +1,174 @@ +/* tractitan: suivi de traceurs avec constantes de temps de rappel */ +/* GCCM */ + +#include "titan.h" + +void tractitan_( double *RB, char CORPS[][10], double Y[][NLEV], + double Y0[][NLEV], double *FIN ) +{ + char outlog[100],corps[100][10]; + int i,j,k,l; + double annee,**tau,**ym1; + double cm,conv,cp,delta,deltamax,deltao; + double test,time,ts; + char str2[15]; + FILE *out; + + for( i = 0; i <= NC; i++) + { + strcpy( corps[i], CORPS[i] ); + corps[i][strcspn(CORPS[i], " ")] = '\0'; + } + + time = ts = 0.0e0; + annee = 9.46728e8; + strcpy( outlog, "chimietitan" ); + strcat( outlog, ".log" ); + deltamax = 2.e5; + + deltao = delta = 1.e5; + + ym1 = dm2d( 0, NC-1, 0, NLEV-1 ); + tau = dm2d( 0, NC-1, 0, NLEV-1 ); + +/* debug */ +/* + out = fopen( "err.log", "a" ); + fprintf( out,"%s\n", ); + fclose( out ); +*/ + +/* Composition pour le rappel (identique a inichim): Y0 */ + +/* initialisation ym1 */ + + for( j = 0; j <= NLEV-1; j++ ) + for( i = 0; i <= NC-1; i++ ) ym1[i][j] = Y[i][j]; + +/* initialisation tau sans dependance en lat */ + + for( i = 0; i <= NC-1; i++ ) + { + for( j = NLEV-1; j >= 0; j-- ) + { + tau[i][j] = 1.e6; /* autres corps = 1.e6 s, donc rappel tres fort */ + + if( strcmp(corps[i],"C2H2") == 0 ) + tau[i][j] = annee*pow( 10., 2.+1.*(100.-(RB[j]-R0))/200. ); + if( strcmp(corps[i],"C2H6") == 0 ) + tau[i][j] = annee*pow( 10., 1.+1.*(200.-(RB[j]-R0))/300. ); + if( strcmp(corps[i],"HCN") == 0 ) + { + if( (RB[j]-R0) >= 350. ) + tau[i][j] = annee*pow( 10., 1.+1.3*((RB[j]-R0)-350.)/150. ); + else + tau[i][j] = annee*10.; + } + if( strcmp(corps[i],"C4H2") == 0 ) + { + if( (RB[j]-R0) >= 300. ) + tau[i][j] = annee*pow( 10.,-1.+0.3*(300.-(RB[j]-R0))/200. ); + else + tau[i][j] = annee*pow( 10., 0.+1.0*(100.-(RB[j]-R0))/200. ); + } + } +/* COUCHES HAUTES: RAPPEL FORCE PLUS GRAND */ + tau[i][NLEV-1] = min(tau[i][NLEV-1],annee/100.); + tau[i][NLEV-2] = min(tau[i][NLEV-2],annee/50.); + tau[i][NLEV-3] = min(tau[i][NLEV-3],annee/10.); +/* tau[i][NLEV-4] = min(tau[i][NLEV-4],annee/100.); */ + } + +/* out = fopen( outlog, "a" ); */ +/* vu la rapidite, on laisse le fichier ouvert pendant toute la boucle */ + +/* ***************** */ +/* Main time loop. */ +/* ***************** */ + + while( time < (*FIN) ) + { + for( i = 0; i <= NC-1; i++ ) + { +/* rappel */ +/* ------ */ + for( j = NLEV-2; j >= 0; j-- ) + Y[i][j] += delta * ( Y0[i][j] - Y[i][j] ) / tau[i][j]; +/* on laisse fixe la couche la plus haute */ + Y[i][NLEV-1] = Y0[i][NLEV-1]; + } + +/* test evolution delta */ +/* -------------------- */ + for( j = 0; j <= NLEV-2; j++ ) if( (RB[j]-R0) >= 90. ) + for( i = 0; i <= NC-1; i++ ) + { + test = 1.0e-15; + if( ( Y[i][j] > test ) && ( ym1[i][j] > test ) ) + { + conv = fabs( Y[i][j] - ym1[i][j] ) / ym1[i][j]; + if( conv > ts ) + { +/* + if( conv > 0.1 ) + { + fprintf(out, "%d %s %e %e\n",j,corps[i],ym1[i][j],Y[i][j]); + } +*/ + ts = conv; + } + } + } +/* + fprintf(out, "%e %e %e\n",time,delta,ts); +*/ + if( ts < 0.1e0 ) + { + for( i = 0; i <= NC-1; i++ ) + for( j = 0; j <= NLEV-1; j++ ) + if( Y[i][j] >= 1.0e0 ) + { +/* + fprintf( out, "WARNING %s mixing ratio is %e %e at %d", + corps[i], ym1[i][j], Y[i][j], j ); + fclose( out ); +*/ + exit(0); + } + for( j = 0; j <= NLEV-1; j++ ) + for( i = 0; i <= NC-1; i++ ) ym1[i][j] = Y[i][j]; + time += ( deltao = delta ); + if( ts < 1.00e-5 ) delta *= 10.e0; + if( ( ts > 1.00e-5 ) && ( ts < 1.0e-4 ) ) delta *= 5.0e0; + if( ( ts > 1.00e-4 ) && ( ts < 1.0e-3 ) ) delta *= 2.0e0; + if( ( ts > 0.001e0 ) && ( ts < 0.01e0 ) ) delta *= 1.5e0; + if( ( ts > 0.010e0 ) && ( ts < 0.05e0 ) ) delta *= 1.1e0; + + delta = min( deltamax, delta ); + + if( ( time + delta ) > (*FIN) ) + { + delta = (*FIN) - time; + time = (*FIN); + } + } + else + { + for( j = 0; j <= NLEV-1; j++ ) + for( i = 0; i <= NC-1; i++ ) Y[i][j] = ym1[i][j]; + delta *= 0.3e0; + } + ts = 0.0e0; + } + +/* **************** */ +/* end of main loop */ +/* **************** */ + +/* + fprintf( out, "%e\n", time ); + fclose( out ); +*/ + fdm2d( ym1, 0, NC-1, 0 ); + fdm2d( tau, 0, NC-1, 0 ); +} Index: trunk/LMDZ.TITAN.old/libf/dyn3d =================================================================== --- trunk/LMDZ.TITAN.old/libf/dyn3d (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/dyn3d (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/dyn3d Index: trunk/LMDZ.TITAN.old/libf/dyn3d_common =================================================================== --- trunk/LMDZ.TITAN.old/libf/dyn3d_common (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/dyn3d_common (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/dyn3d_common Index: trunk/LMDZ.TITAN.old/libf/dyn3dpar =================================================================== --- trunk/LMDZ.TITAN.old/libf/dyn3dpar (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/dyn3dpar (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/dyn3dpar Index: trunk/LMDZ.TITAN.old/libf/dynphy_lonlat =================================================================== --- trunk/LMDZ.TITAN.old/libf/dynphy_lonlat (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/dynphy_lonlat (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/dynphy_lonlat Index: trunk/LMDZ.TITAN.old/libf/filtrez =================================================================== --- trunk/LMDZ.TITAN.old/libf/filtrez (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/filtrez (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/filtrez Index: trunk/LMDZ.TITAN.old/libf/grid =================================================================== --- trunk/LMDZ.TITAN.old/libf/grid (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/grid (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/grid Index: trunk/LMDZ.TITAN.old/libf/misc =================================================================== --- trunk/LMDZ.TITAN.old/libf/misc (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/misc (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/misc Index: trunk/LMDZ.TITAN.old/libf/phy_common =================================================================== --- trunk/LMDZ.TITAN.old/libf/phy_common (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phy_common (revision 1643) @@ -0,0 +1,1 @@ +link ../../LMDZ.COMMON/libf/phy_common Index: trunk/LMDZ.TITAN.old/libf/phytitan/YOEGWD.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/YOEGWD.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/YOEGWD.h (revision 1643) @@ -0,0 +1,10 @@ +! ----------------------------------------------------------------- +!* *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS +! ----------------------------------------------------------------- +! + integer :: NKTOPG,NTOP + real :: GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT + real :: GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC + COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT & + & ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NTOP,GSSEC,GTSEC,GVSEC + Index: trunk/LMDZ.TITAN.old/libf/phytitan/YOMCST.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/YOMCST.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/YOMCST.h (revision 1643) @@ -0,0 +1,35 @@ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! A1.0 Fundamental constants + REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO +! A1.1 Astronomical constants + REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA +! A1.1.bis Constantes concernant l'orbite de la Terre: + REAL R_ecc, R_peri, R_incl +! A1.2 Geoide + REAL RA,RG,R1SA +! A1.3 Radiation +! REAL RSIGMA,RI0 + REAL RSIGMA +! A1.4 Thermodynamic gas phase + REAL R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV + REAL RKAPPA,RETV +! A1.5,6 Thermodynamic liquid,solid phases + REAL RCW,RCS +! A1.7 Thermodynamic transition of phase + REAL RLVTT,RLSTT,RLMLT,RTT,RATM +! A1.8 Curve of saturation + REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS + REAL RALPD,RBETD,RGAMD +! + COMMON/YOMCST/RPI ,RCLUM, RHPLA, RKBOL, RNAVO ,RDAY ,REA & + & ,REPSM ,RSIYEA,RSIDAY,ROMEGA , R_ecc, R_peri, R_incl & + & ,RA ,RG ,R1SA & + & ,RSIGMA,R ,RMD ,RMV ,RD ,RV ,RCPD ,RCPV,RCVD & + & ,RCVV ,RKAPPA,RETV ,RCW ,RCS ,RLVTT ,RLSTT ,RLMLT ,RTT ,RATM & + & ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS ,RALPD ,RBETD & + & ,RGAMD Index: trunk/LMDZ.TITAN.old/libf/phytitan/aaam_bud.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/aaam_bud.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/aaam_bud.F (revision 1643) @@ -0,0 +1,353 @@ + subroutine aaam_bud (iam,nlon,nlev,rjour,rsec, + i rea,rg,ome, + i plat,plon,phis, + i dragu,liftu,clu, + i dragv,liftv,clv, + i p, u, v) +c + use dimphy + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo + implicit none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 20031020 +c Object: Compute different terms of the axial AAAM Budget. +C No outputs, every AAM quantities are written on the IAM +C File. +C WARNING: Only valid for regular rectangular grids. +C REMARK: CALL DANS PHYSIQ AFTER lift_noro: +C CALL aaam_bud (27,klon,klev,rjourvrai,gmtime, +C C ra,rg,romega, +C C rlat,rlon,pphis, +C C zustrdr,zustrli,zustrcl, +C C zvstrdr,zvstrli,zvstrcl, +C C paprs,u,v) +C +C====================================================================== +c Explicit Arguments: +c ================== +c iam-----input-I-File number where AAMs and torques are written +c It is a formatted file that has been opened +c in physiq.F +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c rjour---input-R-Jour compte depuis le debut de la simu (run.def) +c rsec----input-R-Seconde de la journee +c rea-----input-R-Earth radius +c rg------input-R-gravity constant +c ome-----input-R-Earth rotation rate +c plat ---input-R-Latitude en degres +c plon ---input-R-Longitude en degres +c phis ---input-R-Geopotential at the ground +c dragu---input-R-orodrag stress (zonal) +c liftu---input-R-orolift stress (zonal) +c clu-----input-R-Boundary layer stress (zonal) +c dragv---input-R-orodrag stress (Meridional) +c liftv---input-R-orolift stress (Meridional) +c clv-----input-R-Boundary layer stress (Meridional) +c p-------input-R-Pressure (Pa) at model half levels +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c +c +c Implicit Arguments: +c =================== +c +c nbp_lon--common-I: Number of longitude intervals +c nbp_lat-1--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c nbp_lon*(nbp_lat-1-1)+2 for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c dlat-----R: Latitude increment (Radians) +c dlon-----R: Longitude increment (Radians) +c raam ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c oaam ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c tmou-----R: Resolved Mountain torque (3 components) +c tsso-----R: Parameterised Moutain drag torque (3 components) +c tbls-----R: Parameterised Boundary layer torque (3 components) +c +c LOCAL ARRAY: +c =========== +c zs ---R: Topographic height +c ps ---R: Surface Pressure +c ub ---R: Barotropic wind zonal +c vb ---R: Barotropic wind meridional +c zlat ---R: Latitude in radians +c zlon ---R: Longitude in radians +c====================================================================== + +c +c ARGUMENTS +c + INTEGER iam,nlon,nlev + REAL rjour,rsec,rea,rg,ome + REAL plat(nlon),plon(nlon),phis(nlon) + REAL dragu(nlon),liftu(nlon),clu(nlon) + REAL dragv(nlon),liftv(nlon),clv(nlon) + REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev) +c +c Variables locales: +c + INTEGER i,j,k,l + REAL xpi,hadley,hadday + REAL dlat,dlon + REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3) + integer iax + + + REAL ZS(801,401),PS(801,401) + REAL UB(801,401),VB(801,401) + REAL SSOU(801,401),SSOV(801,401) + REAL BLSU(801,401),BLSV(801,401) + REAL ZLON(801),ZLAT(401) +C +C PUT AAM QUANTITIES AT ZERO: +C + if(nbp_lon+1.gt.801.or.nbp_lat.gt.401)then + print *,' Pb de dimension dans aaam_bud' + stop + endif + + xpi=acos(-1.) + hadley=1.e18 + hadday=1.e18*1.e7 + IF (klon_glo.EQ.1) THEN + dlat=xpi + ELSE + dlat=xpi/float(nbp_lat-1) + ENDIF + dlon=2.*xpi/float(nbp_lon) + + do iax=1,3 + oaam(iax)=0. + raam(iax)=0. + tmou(iax)=0. + tsso(iax)=0. + tbls(iax)=0. + enddo + +C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND: + +C North pole values (j=1): + + l=1 + + ub(1,1)=0. + vb(1,1)=0. + do k=1,nlev + ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + zlat(1)=plat(l)*xpi/180. + + do i=1,nbp_lon+1 + + zs(i,1)=phis(l)/rg + ps(i,1)=p(l,1) + ub(i,1)=ub(1,1) + vb(i,1)=vb(1,1) + ssou(i,1)=dragu(l)+liftu(l) + ssov(i,1)=dragv(l)+liftv(l) + blsu(i,1)=clu(l) + blsv(i,1)=clv(l) + + enddo + + + do j = 2,nbp_lat-1 + +C Values at Greenwich (Periodicity) + + zs(nbp_lon+1,j)=phis(l+1)/rg + ps(nbp_lon+1,j)=p(l+1,1) + ssou(nbp_lon+1,j)=dragu(l+1)+liftu(l+1) + ssov(nbp_lon+1,j)=dragv(l+1)+liftv(l+1) + blsu(nbp_lon+1,j)=clu(l+1) + blsv(nbp_lon+1,j)=clv(l+1) + zlon(nbp_lon+1)=-plon(l+1)*xpi/180. + zlat(j)=plat(l+1)*xpi/180. + + ub(nbp_lon+1,j)=0. + vb(nbp_lon+1,j)=0. + do k=1,nlev + ub(nbp_lon+1,j)=ub(nbp_lon+1,j)+u(l+1,k)* + & (p(l+1,k)-p(l+1,k+1))/rg + vb(nbp_lon+1,j)=vb(nbp_lon+1,j)+v(l+1,k)* + & (p(l+1,k)-p(l+1,k+1))/rg + enddo + + + do i=1,nbp_lon + + l=l+1 + zs(i,j)=phis(l)/rg + ps(i,j)=p(l,1) + ssou(i,j)=dragu(l)+liftu(l) + ssov(i,j)=dragv(l)+liftv(l) + blsu(i,j)=clu(l) + blsv(i,j)=clv(l) + zlon(i)=plon(l)*xpi/180. + + ub(i,j)=0. + vb(i,j)=0. + do k=1,nlev + ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + enddo + + enddo + + +C South Pole + + l=l+1 + ub(1,nbp_lat)=0. + vb(1,nbp_lat)=0. + do k=1,nlev + ub(1,nbp_lat)=ub(1,nbp_lat)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,nbp_lat)=vb(1,nbp_lat)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + zlat(nbp_lat)=plat(l)*xpi/180. + + do i=1,nbp_lon+1 + zs(i,nbp_lat)=phis(l)/rg + ps(i,nbp_lat)=p(l,1) + ssou(i,nbp_lat)=dragu(l)+liftu(l) + ssov(i,nbp_lat)=dragv(l)+liftv(l) + blsu(i,nbp_lat)=clu(l) + blsv(i,nbp_lat)=clv(l) + ub(i,nbp_lat)=ub(1,nbp_lat) + vb(i,nbp_lat)=vb(1,nbp_lat) + enddo + +C +C MOMENT ANGULAIRE +C + DO j=1,nbp_lat-1 + DO i=1,nbp_lon + + raam(1)=raam(1)-rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +cos(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c +rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(2)=raam(2)-rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +sin(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c -rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5* + c (sin(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(3)=raam(3)+rea**3*dlon*dlat*0.5* + c (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1)) + + oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1)) + + ENDDO + ENDDO + +C +C COUPLE DES MONTAGNES: +C + + DO j=1,nbp_lat-1 + DO i=1,nbp_lon + tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + ENDDO + ENDDO + + DO j=2,nbp_lat-1 + DO i=1,nbp_lon + tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j)) + tmou(3)=tmou(3)-rea**2*dlat*0.5* + c cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j)) + ENDDO + ENDDO +C +C COUPLES DES DIFFERENTES FRICTION AU SOL: +C + l=1 + DO j=2,nbp_lat-1 + DO i=1,nbp_lon + l=l+1 + tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *sin(zlon(i)) + + tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *cos(zlon(i)) + + tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *cos(zlat(j)) + + tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *sin(zlon(i)) + + tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *cos(zlon(i)) + + tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *cos(zlat(j)) + + ENDDO + ENDDO + + +c write(*,*) 'AAM',rsec, +c c raam(3)/hadday,oaam(3)/hadday, +c c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley + + write(iam,100)rjour+rsec/1.e7, + c raam(1)/hadday,oaam(1)/hadday, + c tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley, + c raam(2)/hadday,oaam(2)/hadday, + c tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley, + c raam(3)/hadday,oaam(3)/hadday, + c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley +100 format(F12.5,15(1x,F12.5)) +c00 format(F12.5,5(1x,F12.5)) + + write(iam+1,*)((zs(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((ps(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((ub(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((vb(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((ssou(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((ssov(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((blsu(i,j),i=1,nbp_lon),j=1,nbp_lat) + write(iam+1,*)((blsv(i,j),i=1,nbp_lon),j=1,nbp_lat) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/ajsec.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ajsec.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ajsec.F (revision 1643) @@ -0,0 +1,211 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $ +! +! ADAPTATION GCM POUR CP(T) + SUBROUTINE ajsec(paprs, pplay, ppk, tfi, ufi, vfi, nq, qfi, + . d_tfi, d_ufi, d_vfi, d_qfi) + + use dimphy + use mod_grid_phy_lmdz, only: nbp_lev + use cpdet_phy_mod, only: t2tpot, tpot2t + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c S. Lebonnois, 10/2007: +c melange u et v comme dans convadj (MARS) +c====================================================================== +c Arguments: +c tfi-------input-R- Temperature +c ufi-------input-R- vent zonal +c vfi-------input-R- vent meridien +c nq--------input-R- nombre de traceurs +c qfi-------input-R- traceurs +c +c d_tfi-----output-R-Incrementation de la temperature +c d_ufi-----output-R-Incrementation du vent zonal +c d_vfi-----output-R-Incrementation du vent meridien +c d_qfi-----output-R-Incrementation des traceurs +c====================================================================== +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL ppk(klon,klev) + INTEGER nq + REAL tfi(klon,klev), d_tfi(klon,klev) + REAL ufi(klon,klev), d_ufi(klon,klev) + REAL vfi(klon,klev), d_vfi(klon,klev) + REAL qfi(klon,klev,nq), d_qfi(klon,klev,nq) +c + INTEGER,save :: limbas, limhau ! les couches a ajuster +c + REAL zh(klon,klev) + REAL zu(klon,klev),zv(klon,klev) + REAL zt(klon,klev),zq(klon,klev,nq) + REAL zdp(klon,klev) + REAL zpkdp(klon,klev) + REAL hm,sm,zum,zvm,zalpha,zqm(nq) + LOGICAL modif(klon), down + INTEGER i, k, k1, k2, iq +c +c Initialisation: +c + limbas=1 + limhau=klev + + DO k = 1, klev + DO i = 1, klon + d_tfi(i,k) = 0.0 + d_ufi(i,k) = 0.0 + d_vfi(i,k) = 0.0 + d_qfi(i,k,:) = 0.0 + zu(i,k) = ufi(i,k) + zv(i,k) = vfi(i,k) + zq(i,k,:) = qfi(i,k,:) + ENDDO + ENDDO +c------------------------------------- passage en temperature potentielle +! ADAPTATION GCM POUR CP(T) + call t2tpot(klon*nbp_lev,tfi,zh,ppk) +c + DO k = limbas, limhau + DO i = 1, klon + zdp(i,k) = paprs(i,k)-paprs(i,k+1) + zpkdp(i,k) = ppk(i,k) * zdp(i,k) + ENDDO + ENDDO +c +c------------------------------------- detection des profils a modifier + DO i = 1, klon + modif(i) = .FALSE. + ENDDO + DO k = limbas+1, limhau + DO i = 1, klon + IF (.NOT.modif(i)) THEN + IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + DO 1080 i = 1, klon + IF (modif(i)) THEN + k2 = limbas + 8000 CONTINUE + k2 = k2 + 1 + IF (k2 .GT. limhau) goto 8001 + IF (zh(i,k2) .LT. zh(i,k2-1)) THEN + k1 = k2 - 1 + k = k1 + sm = zpkdp(i,k2) + hm = zh(i,k2) + 8020 CONTINUE + sm = sm +zpkdp(i,k) + hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm + down = .FALSE. + IF (k1 .ne. limbas) THEN + IF (hm .LT. zh(i,k1-1)) down = .TRUE. + ENDIF + IF (down) THEN + k1 = k1 - 1 + k = k1 + ELSE + IF ((k2 .EQ. limhau)) GOTO 8021 + IF ((zh(i,k2+1).GE.hm)) GOTO 8021 + k2 = k2 + 1 + k = k2 + ENDIF + GOTO 8020 + 8021 CONTINUE +c------------ nouveau profil : constant (valeur moyenne) +c------------ et melange partiel des vents + zalpha=0. + zum=0. + zvm=0. + zqm=0. + DO k = k1, k2 + zalpha=zalpha+ABS(zh(i,k)-hm)*zdp(i,k) + zh(i,k) = hm + zum=zum+ufi(i,k)*zdp(i,k) + zvm=zvm+vfi(i,k)*zdp(i,k) + do iq=1,nq + zqm(iq)=zqm(iq)+qfi(i,k,iq)*zdp(i,k) + enddo + ENDDO + zalpha=zalpha/(hm*(paprs(i,k1)-paprs(i,k2+1))) + zum=zum/(paprs(i,k1)-paprs(i,k2+1)) + zvm=zvm/(paprs(i,k1)-paprs(i,k2+1)) + do iq=1,nq + zqm(iq)=zqm(iq)/(paprs(i,k1)-paprs(i,k2+1)) + enddo + + IF(zalpha.GT.1.) THEN + PRINT*,'WARNING dans ajsec zalpha=',zalpha +c STOP + zalpha=1. + ELSE +c IF(zalpha.LT.0.) STOP + IF(zalpha.LT.1.e-5) zalpha=1.e-4 + ENDIF +c ---------------------------- +c TEST --- PAS DE MELANGE DE U +c zalpha=0. +c ---------------------------- + + DO k=k1,k2 + zu(i,k)=ufi(i,k)+zalpha*(zum-ufi(i,k)) + zv(i,k)=vfi(i,k)+zalpha*(zvm-vfi(i,k)) + do iq=1,nq + zq(i,k,iq)=qfi(i,k,iq)+zalpha*(zqm(iq)-qfi(i,k,iq)) + enddo + ENDDO + k2 = k2 + 1 + ENDIF + GOTO 8000 + 8001 CONTINUE + ENDIF + 1080 CONTINUE +c +c------------------------------------- passage en temperature +c------------------------------------- et calcul du d_t +! ADAPTATION GCM POUR CP(T) + call tpot2t(klon*nbp_lev,zh,zt,ppk) + + DO k = limbas, limhau + DO i = 1, klon + d_tfi(i,k) = zt(i,k) - tfi(i,k) + d_ufi(i,k) = zu(i,k) - ufi(i,k) + d_vfi(i,k) = zv(i,k) - vfi(i,k) + do iq=1,nq + d_qfi(i,k,iq) = zq(i,k,iq) - qfi(i,k,iq) + enddo + ENDDO + ENDDO +c + IF (limbas.GT.1) THEN + DO k = 1, limbas-1 + DO i = 1, klon + d_tfi(i,k) = 0.0 + d_ufi(i,k) = 0.0 + d_vfi(i,k) = 0.0 + do iq=1,nq + d_qfi(i,k,iq) = 0.0 + enddo + ENDDO + ENDDO + ENDIF +c + IF (limhau.LT.klev) THEN + DO k = limhau+1, klev + DO i = 1, klon + d_tfi(i,k) = 0.0 + d_ufi(i,k) = 0.0 + d_vfi(i,k) = 0.0 + do iq=1,nq + d_qfi(i,k,iq) = 0.0 + enddo + ENDDO + ENDDO + ENDIF +c + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/averge.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/averge.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/averge.F (revision 1643) @@ -0,0 +1,4 @@ + FUNCTION AVERGE(X,Y) + AVERGE = .5*SQRT(X*Y)+0.25*(X+Y) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/azener.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/azener.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/azener.F (revision 1643) @@ -0,0 +1,10 @@ + FUNCTION AZENER(V,J) + IMPLICIT REAL (A-H,O-Z) + REAL J,JP + VP=V+0.5 + JP=J+1. + E=2359.61*VP-14.456*VP**2+7.51E-3*VP**3+ + $(1.9987-1.87E-2*VP)*J*JP-(5.8E-6-1.E-9*VP)*J**2*JP**2 + AZENER=E + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/ballon.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ballon.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ballon.F (revision 1643) @@ -0,0 +1,395 @@ + subroutine ballon (iam,dtphys,rjour,rsec,plat,plon, + i temp, p, u, v, geop) + + use dimphy + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat + implicit none + +c====================================================================== +c Auteur: S. Lebonnois (LMD/CNRS) date: 20091201 +c Object: Compute balloon trajectories. +C No outputs, every quantities are written on the iam+ Files. +c +c Called by physiq.F if flag ballons activated: +c +c integer ballons +c (...) +c ballons = 1 ! (in initialisations) +c (...) +C OUVERTURE DES FICHIERS FORMATTES CONTENANT LES POSITIONS ET VITESSES +C DES BALLONS +c if (ballons.eq.1) then +c open(30,file='ballons-lat.out',form='formatted') +c open(31,file='ballons-lon.out',form='formatted') +c open(32,file='ballons-u.out',form='formatted') +c open(33,file='ballons-v.out',form='formatted') +c open(34,file='ballons-alt.out',form='formatted') +c write(*,*)'Ouverture des ballons*.out' +c endif !ballons +c (...) +C CALL ballon(30,pdtphys,rjourvrai,gmtime,rlatd,rlond, +CC C t,pplay,u,v,pphi) ! alt above surface (smoothed for GCM) +C C t,pplay,u,v,zphi) ! alt above planet average radius +c (...) +C FERMETURE DES FICHIERS FORMATTES CONTENANT LES POSITIONS ET VITESSES +C DES BALLONS +c if (ballons.eq.1) then +c write(*,*)'Fermeture des ballons*.out' +c close(30) +c close(31) +c close(32) +c close(33) +c close(34) +c endif !ballons +c +C====================================================================== +c Explicit Arguments: +c ================== +c iam-----input-I-File number where latitudes are written +c It is a formatted file that has been opened +c in physiq.F +c other files: iam+1=longitudes +c iam+2=zonal speeds +c iam+3=meridional speeds +c iam+4=altitudes +c dtphys--input-R-pas de temps physique +c rjour---input-R-Jour compte depuis le debut de la simu (run.def) +c rsec----input-R-Seconde de la journee +c plat ---input-R-Latitude en degres +c plon ---input-R-Longitude en degres +c temp----input-R-Temperature (K) at model levels +c p-------input-R-Pressure (Pa) at model levels +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c geop----input-R-Geopotential !! above surface OR average radius +c +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c iim*(jjm-1)+2 for instance +c klev-common-I: Number of vertical layers +c RPI,RKBOL--common-R: Pi, KBoltzman +c RDAY,RA,RG-common-R: day length in s, planet radius, gravity +c====================================================================== +c Local Variables: +c ================ +c +c nb ---I: number of balloons (parameter) +c phib ---R: Latitude of balloon in radians +c lamb ---R: Longitude of balloon in radians +c lognb ---R: log(density) of balloon +c ub ---R: zonal speed of balloon +c vb ---R: meridional speed of balloon +c altb ---R: altitude of balloon +c zlat ---R: Latitude in radians +c zlon ---R: Longitude in radians +c logn ---R: log(density) +c alt ---R: altitude !! above surface OR average radius +c ull ---R: zonal wind for one balloon on the lognb surface +c vll ---R: meridional wind for one balloon on the lognb surface +c aal ---R: altitude for one balloon on the lognb surface +c====================================================================== + +#include "YOMCST.h" +c +c ARGUMENTS +c + INTEGER iam + REAL dtphys,rjour,rsec,plat(klon),plon(klon) + REAL temp(klon,klev),p(klon,klev) + REAL u(klon,klev),v(klon,klev),geop(klon,klev) +c +c Variables locales: +c + INTEGER i,j,k,l,nb,n + parameter (nb=20) !! Adjust the format on line 100 !! + INTEGER jj,ii,ll + + REAL,SAVE,ALLOCATABLE :: zlon(:),zlat(:) + + REAL time + REAL logn(klon,klev),ull(klon),vll(klon) + REAL alt(klon,klev),aal(klon) + real ub(nb),vb(nb),phib(nb),lamb(nb),lognb(nb),altb(nb) + save phib,lamb,lognb + + REAL factalt + +c RungeKutta order - If not RK, Nrk=1 + integer Nrk,irk + parameter (Nrk=1) + real dtrk + + logical first + save first + data first/.true./ + + time = rjour*RDAY+rsec + logn(:,:) = log10(p(:,:)/(RKBOL*temp(:,:))) + alt(:,:) = geop(:,:)/RG + +c--------------------------------------------- +C INITIALIZATIONS +c--------------------------------------------- + if (first) then + + print*,"BALLOONS ACTIVATED" + + allocate(zlon(nbp_lon+1)) + allocate(zlat(nbp_lat)) + +C Latitudes: + zlat(1)=plat(1)*RPI/180. + do j = 2,nbp_lat-1 + k=(j-2)*nbp_lon+2 + zlat(j)=plat(k)*RPI/180. + enddo + zlat(nbp_lat)=plat(klon)*RPI/180. + +C Longitudes: + do i = 1,nbp_lon + k=i+1 + zlon(i)=plon(k)*RPI/180. + enddo + zlon(nbp_lon+1)=zlon(1)+2.*RPI + +c verif init lat de 90 à -90, lon de -180 à 180 +c print*,"Latitudes:",zlat*180./RPI +c print*,"Longitudes:",zlon*180./RPI +c stop + +c initial positions of balloons (in degrees for lat/lon) + do j=1,5 + do i=1,4 + k=(j-1)*4+i + phib(k)= (j-1)*20.*RPI/180. + lamb(k)= (i-3)*90.*RPI/180. ! de -180 à 90 +c A REVOIR POUR TITAN + lognb(k)= log10(5.e4/(RKBOL*300.)) ! ~55km in VIRA model + enddo + enddo + print*,"Balloon density (m^-3)=",10.**(lognb(1)) + +c print*,"log(density) profile:" +c do l=1,klev +c print*,logn(klon/2,l) +c enddo +c stop !verif init + + first=.false. + endif ! first +c--------------------------------------------- + +c------------------------------------------------- +c loop over the balloons +c------------------------------------------------- + do n=1,nb + +c Interpolation in altitudes +c------------------------------------------------- + do k=1,klon + ll=1 ! en bas + do l=2,klev + if (lognb(n).lt.logn(k,l)) ll=l + enddo + factalt= (lognb(n)-logn(k,ll))/(logn(k,ll+1)-logn(k,ll)) + ull(k) = u(k,ll+1)*factalt + u(k,ll)*(1-factalt) + vll(k) = v(k,ll+1)*factalt + v(k,ll)*(1-factalt) + aal(k) = alt(k,ll+1)*factalt + alt(k,ll)*(1-factalt) + enddo + +c Interpolation in latitudes and longitudes +c------------------------------------------- + call wind_interp(ull,vll,aal,zlat,zlon, + . phib(n),lamb(n),ub(n),vb(n),altb(n)) + + enddo ! over balloons +c------------------------------------------------- + +c------------------------------------------------- +c Output of positions and speed at time +c------------------------------------------------- + + write(iam, 100) time, phib*180./RPI + write(iam+1,100) time, lamb*180./RPI + write(iam+2,100) time, ub + write(iam+3,100) time, vb + write(iam+4,100) time, altb +c stop !verif init + +c !!!!!!!!!!!!!!!! nb !!!!!!!!!!!!!!!!! +100 format(E14.7,20(1x,E12.5)) + +c------------------------------------------------- +c Implementation: positions at time+dt +c RK order Nrk +c------------------------------------------------- + + dtrk = dtphys/Nrk + time=time+dtrk + + do n=1,nb + call pos_implem(phib(n),lamb(n),ub(n),vb(n),dtrk) + enddo + + if (Nrk.gt.1) then + do irk=2,Nrk + do n=1,nb + time=time+dtrk + call wind_interp(ull,vll,aal,zlat,zlon, + . phib(n),lamb(n),ub(n),vb(n),altb(n)) + call pos_implem(phib(n),lamb(n),ub(n),vb(n),dtrk) + enddo + enddo + endif + + end + +c====================================================================== +c====================================================================== +c====================================================================== + + subroutine wind_interp(map_u,map_v,map_a,latit,longit, + . phi,lam,ubal,vbal,abal) + + use dimphy + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat + implicit none + +c====================================================================== +c Auteur: S. Lebonnois (LMD/CNRS) date: 20091201 +c Object: interpolate balloon speed from its position. +C====================================================================== +c Explicit Arguments: +c ================== +c map_u ---R: zonal wind on the lognb surface +c map_v ---R: meridional wind on the lognb surface +c map_a ---R: altitude on the lognb surface +c latit ---R: Latitude in radians +c longit---R: Longitude in radians +c phi ---R: Latitude of balloon in radians +c lam ---R: Longitude of balloon in radians +c ubal ---R: zonal speed of balloon +c vbal ---R: meridional speed of balloon +c abal ---R: altitude of balloon +c====================================================================== +c Local Variables: +c ================ +c +c ujj ---R: zonal wind interpolated in latitude +c vjj ---R: meridional wind interpolated in latitude +c ajj ---R: altitude interpolated in latitude +c====================================================================== + +#include "YOMCST.h" +c +c ARGUMENTS +c + real map_u(klon),map_v(klon),map_a(klon) + real latit(nbp_lat),longit(nbp_lon) + real phi,lam,ubal,vbal,abal +c +c Variables locales: +c + INTEGER i,j,k + INTEGER jj,ii + REAL ujj(nbp_lon+1),vjj(nbp_lon+1),ajj(nbp_lon+1) + REAL factlat,factlon + +c Interpolation in latitudes +c------------------------------------------------- + jj=1 ! POLE NORD + do j=2,nbp_lat-1 + if (phi.lt.latit(j)) jj=j + enddo + factlat = (phi-latit(jj))/(latit(jj+1)-latit(jj)) + +c pole nord + if (jj.eq.1) then + do i=1,nbp_lon + ujj(i) = map_u(i+1)*factlat + map_u(1)*(1-factlat) + vjj(i) = map_v(i+1)*factlat + map_v(1)*(1-factlat) + ajj(i) = map_a(i+1)*factlat + map_a(1)*(1-factlat) + enddo +c pole sud + elseif (jj.eq.nbp_lat-1) then + do i=1,nbp_lon + k = (jj-2)*nbp_lon+1+i + ujj(i) = map_u(klon)*factlat + map_u(k)*(1-factlat) + vjj(i) = map_v(klon)*factlat + map_v(k)*(1-factlat) + ajj(i) = map_a(klon)*factlat + map_a(k)*(1-factlat) + enddo +c autres latitudes + else + do i=1,nbp_lon + k = (jj-2)*nbp_lon+1+i + ujj(i) = map_u(k+nbp_lon)*factlat + map_u(k)*(1-factlat) + vjj(i) = map_v(k+nbp_lon)*factlat + map_v(k)*(1-factlat) + ajj(i) = map_a(k+nbp_lon)*factlat + map_a(k)*(1-factlat) + enddo + endif + ujj(nbp_lon+1)=ujj(1) + vjj(nbp_lon+1)=vjj(1) + ajj(nbp_lon+1)=ajj(1) + +c Interpolation in longitudes +c------------------------------------------------- + ii=1 ! lon=-180 + do i=2,nbp_lon + if (lam.gt.longit(i)) ii=i + enddo + factlon = (lam-longit(ii))/(longit(ii+1)-longit(ii)) + ubal = ujj(ii+1)*factlon + ujj(ii)*(1-factlon) + vbal = vjj(ii+1)*factlon + vjj(ii)*(1-factlon) + abal = ajj(ii+1)*factlon + ajj(ii)*(1-factlon) + + end + +c====================================================================== +c====================================================================== +c====================================================================== + + subroutine pos_implem(phi,lam,ubal,vbal,dt) + + use dimphy + implicit none + +c====================================================================== +c Auteur: S. Lebonnois (LMD/CNRS) date: 20091201 +c Object: implementation of balloon position. +C====================================================================== +c Explicit Arguments: +c ================== +c phi ---R: Latitude of balloon in radians +c lam ---R: Longitude of balloon in radians +c ubal ---R: zonal speed of balloon +c vbal ---R: meridional speed of balloon +c dt ---R: time step +c====================================================================== + +#include "YOMCST.h" +c +c ARGUMENTS +c + real phi,lam,ubal,vbal,abal,dt + +c incrementation longitude + lam = lam + ubal*dt/(RA*cos(phi)) +c maintenue entre -PI et PI: + do while (lam.ge.RPI) + lam=lam-2*RPI + enddo + do while (lam.lt.(-1.*RPI)) + lam=lam+2*RPI + enddo +c incrementation latitude + phi = phi + vbal*dt/RA +c maintenue entre -PI/2 et PI/2: + if (phi.ge.( 0.5*RPI)) phi= RPI-phi + if (phi.le.(-0.5*RPI)) phi=-1.*RPI-phi + + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/brume3D.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/brume3D.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/brume3D.F (revision 1643) @@ -0,0 +1,1227 @@ + subroutine brume(ngrid,tab1,x1, + & xnz,xnrad,taused,ihor, + & pmu0,pfract, + & precip) + + +*1 c nombre de particules de la grille de rayon r a l'altitude z +*2 dt, pas de temps, en heure. + +*--------------------------------------------------------------* +* * +* ENTRE 0 ET 1000 KILOMETRES * +* * +* la dimension fractale est en tableau, attention au * +* raccordement entre le regime moleculaire et le regime * +* fluide * +* * +* Modele microphysique: Cabane et al.,1992 / * +* Modele version fractale: Cabane et al.,1993 / * +* * +*--------------------------------------------------------------* +* VERSION DU 2 JUIN 1993 --- AUT 1994 --- 11/04/96 +* +* changer: altitude de production z0=/taux de production ctot= +* : la charge/micron, ne +* : df(h),rf... +* raccordement aknc +* +* declaration des blocs communs +*------------------------------ + + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + + real pmu0,pfract + + common/ctps/li,lf,dt + common/con/c + common/coag/k + common/effets/xsaison + + +* declaration des variables communes +* ---------------------------------- + + integer xnz,xnrad,ngrid + integer li,lf,ihor + real dt,g + real c0(nz,nrad),c(nz,nrad,2) + real k(nz,nrad,nrad),knu + real xsaison + real taused(nz,nrad) + real precip(ngrid,5) + + + +* variables internes +* ------------------ + + integer h,ti,itime,i,j + real tab1(nz,nrad) + real x1 + real somme,v1,dice3 + + real vitesse + + save itime + data itime/0/ + +* controles +* --------- + + if (nrad.ne.xnrad) stop 'nrad.ne.xnrad' + if (nz.ne.xnz) stop 'nz.ne.xnz' + + do i=1,nz + do j=1,nrad + c(i,j,1)=tab1(i,j) + c(i,j,2)=0.0 + enddo + enddo + + dt=x1 + +* initialisation unique +* -------------- + +c if (itime.eq.0) then +c ITIME=1 +c endif + +* initialisation +* -------------- + + call init + call calcoag + +* effet saisonnier +* ---------------- + + + xsaison=0. + xsaison=pmu0*4.*pfract + !=Pi si fract=1/2 (equinoxe) et + ! si mu0(ihor)=1 sous le soleil + ! exactement. + +c xsaison=0. +c if (ihor.le.9.or.ihor.ge.41) xsaison=8. ! rapport des surfaces +c xsaison=1. + + do i=1,nz,1 + do j=1,nrad + v1=vitesse(i,j,0) + g=g0*(rtit/(rtit+z(i)))**2 + taused(i,j)=rgp*t(i)/(mn2*g)/v1 + enddo + enddo + + call coagul + + call production(ihor) + + li=3-li + lf=3-lf + + call sedif(dice3) +c En theorie, dice3 est NEGATIF (en sedimentant on ne fait que perdre des aerosols) +c Les precipitations sont comptees positivement. (ET ON NE PREND QUE DES VALEURS POSITIVES) + precip(ihor,5)=AMAX1(-dice3/rhol,0.) ! m3/m2=m + + li=3-li + lf=3-lf + + do i=1,nz + do j=1,nrad + tab1(i,j)=c(i,j,li) ! li=1 + enddo + enddo + + return + + end +*________________________________________________________________________ + + subroutine coagul + +********************************************************* +* ce programme calcule la nouvelle concentration dans * +* le a ieme intervalle de rayon, a l'altitude h, a * +* l'instant t+dt * +********************************************************* + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + +* declaration des blocs communs +*------------------------------ + + common/ctps/li,lf,dt + common/con/c + +* declaration des variables +* -------------------------- + + integer li,lf + real dt + real c(nz,nrad,2) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,a + real pr,pe + +* traitement +* ---------- + + do h=nztop,nz + do a=1,nrad + call pertpro(h,a,pe,pr) +c if((1+dt*pe).lt.0.) stop 'denom.eq.0' + c(h,a,lf)=(c(h,a,li)+pr*dt)/(1+dt*pe) + enddo + enddo + + if (nztop.ne.1) then + do h=1,nztop-1 + do a=1,nrad + c(h,a,lf)=c(h,a,li) + enddo + enddo + endif + + return + end + + +*__________________________________________________________________________ + + subroutine calcoag + +*************************************************************** +* * +* Ce programme calcule les coefficients de collection d'une * +* particule de rayon x avec une particule de rayon b a une * +* altitude donnee h * +*************************************************************** + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/ctps/li,lf,dt + common/con/c + common/coag/k + +* declaration des variables +* -------------------------- + + integer li,lf,i + real dt + real c(nz,nrad,2) + real knu,nud,k(nz,nrad,nrad) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,x + real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg + real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb + real rfx,rfb,rpr + real*8 ne,qe,epso + real*8 corelec,yy + + real kco,vx,vb,vitesse,sto,ee,a,dd,bb,p0,t0,l0,ccol + real st(37),ef(37) + +* initialisation +* -------------- +c print*,'**** calcoag' + +* -nombres de STOCKES + + data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1, + s 3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9, + s 10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86., + s 187.,600./ + +* -coef. d'efficacite de collection + + ef(1)=3.75 + ef(2)=8.75 + do i=3,37 + ef(i)=ef(i-1)+2.5 + enddo + + do i=1,37 + ef(i)=ef(i)*1e-2 + enddo + + qe=1.6e-19 + ne=-30.e+6 ! "vieille valeur!" + ne=-15.e+6 ! pour fitter DISR ! + + epso=1e-9/(36*pi) + + d=1.257 + e=0.4 + f=-1.1 + +* iteration sur z + + do 1 h=1,nz + nua=nud(h,1) + +* iteration sur les rayons + + do 1 b=1,nrad + + knb=knu(h,b,1) + vb=vitesse(h,b,1) + + do 1 x=1,b + + knx=knu(h,x,1) + vx=vitesse(h,x,1) + +** COAGULATION **************************************************** +** --------------**************************************************** +* calcul du terme correcteur 'slip-flow' + + alphab=d+e*exp(f/knb) + alphax=d+e*exp(f/knx) + +* calcul du coefficient de diffusion + + rfb=(r_e(b)**(3./df(b)))*((rf(b))**(1.-3./df(b))) + rfx=(r_e(x)**(3./df(x)))*((rf(x))**(1.-3./df(x))) + db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb) + dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx) + +* calcul du coefficient de coagulation + + rpr=rfb+rfx + kcg=4*pi*rpr*(db+dx) + +* calcul de la vitesse thermique + + gx=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(x)**3)) + gb=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(b)**3)) + +* calcul du libre parcours apparent des aerosols + + lambb=8*db/(pi*gb) + lambx=8*dx/(pi*gx) + +*calcul du terme correcteur beta + + rm=rpr/2. + dm=(dx+db)/2. + g=sqrt(gx**2+gb**2) + deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5) + s /(6*rfb*lambb)-2*rfb)*sqrt(2.) + deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5) + s /(6*rfx*lambx)-2*rfx)*sqrt(2.) + del=sqrt(deltab**2+deltax**2) + beta=1/((rm/(rm+del/2))+(4*dm/(g*rm))) + +* calcul du coefficient de coagulation corrige + + kcg=kcg*beta +c print*,' kcg:', rfb,rfx,knb,knx,db,dx +c print*,' beta:', gx,gb,lambb,lambx,rm,dm +c print*,' beta:', g,deltab,deltax,del,beta +c print*,' ' + +** COALESCENCE ************************************************** +** -------------************************************************** + + kco=0. + + if (b.eq.x) goto 9 + +* calcul du nombre de Stockes de la petite particule + + sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb) + +* calcul du coef. de Cunningham-Millikan + + a=1.246 + bb=0.42 + dd=0.87 + l0=0.653e-7 + p0=101325. + t0=288. + + ee=1+(l0*t(h)*p0* + & (a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0)))) + s /(rfx*t0*p(h)) + +* calcul du nombre de Stockes corrige + + sto=sto*ee + + if (sto .le. 1.2) goto 9 + + if (sto .ge. 600.) then + ccol=1. + goto 8 + endif + +* recherche du coefficient de collection + + do 3 i=1,37 + if (sto .gt. st(i)) then + goto 3 + endif + if (sto .eq. st(i)) then + ccol=ef(i+1) + else + ccol=ef(i) + endif + goto 8 +3 continue + +* calcul du coefficient de coalescence + +8 kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx) + +9 continue + +** CORRECTION ELECTRICITE ******************************* +** ------------------------****************************** + + yy=1.d0*ne**2*r_e(x)*r_e(b)*qe**2 + & /(1.d0*kbz*t(h)*(r_e(b)+r_e(x))*4*pi*epso) + + + corelec=0. + if (yy.lt.50.) corelec=yy/(exp(yy)-1.) + if (yy.le.1.e-3) corelec=1. + + k(h,b,x)=(kcg+kco)*corelec + k(h,x,b)=k(h,b,x) + + +1 continue + return + end + +*______________________________________________________________________ + + real function lambda(j,indic) +* +*------------------------------------------------------------------* +* fonction calculant le libre parcours moyen des molecules * +* atmospheriques( rayon =ra) se trouvant dans la couche no j. * +* pour indic=0 ...... la particule se trouve a la frontiere entre* +* les couches j et j-1 * +* pour indic=1 ...... la particule se trouve au milieu de la * +* la couche j * +*------------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +* declaration des variables communes +* ---------------------------------- + + integer i,j + +* declaration des variables internes +* ---------------------------------- + + integer indic + real pp,ra + + ra=1.75e-10 + +* traitement +* ---------- + + if (indic.eq.0) then + pp=pb(j) + else + if (indic.ne.1) then + print*,'erreur argument fonction lambda' + return + endif + pp=p(j) + endif + + lambda=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp) + end + +******************************************************************************* + + real function knu(j,k,indic) +* +*--------------------------------------------------------------* +* fonction calculant le nombre de knudsen d'une particule * +* d'aerosol de rayon r_e(k) se trouvant dans la couche no j * +* indic ...... idem function lambda * +*--------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +* declaration des variables internes +* ---------------------------------- + + integer indic,j,k + real lambda,rfk + +* traitement +* ---------- + + if (indic.ne.0 .and.indic.ne.1) then + print*,'erreur argument fonction knu' + return + endif + + rfk=(r_e(k)**(3./df(k)))*((rf(k))**(1.-3./df(k))) + knu=lambda(j,indic)/rfk + end + +***************************************************************************** + + real function nud(j,indic) +* +*--------------------------------------------------------------* +* fonction calculant la viscosite dynamique (en USI) de l'air * +* d'apres la formule de Sutherlant a l'altitude j * +* indic ......... idem fonction lambda * +*--------------------------------------------------------------* +* + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + + integer indic,j + real nud0,c,tt +* + nud0=1.74e-5 + c=109. + + if(indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction nud' + return + endif + + if(indic.eq.0) tt=tb(j) + if (indic.eq.1) tt=t(j) + + nud=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt) + end + +**************************************************************************** + + real function vitesse(j,k,indic) +* +*-----------------------------------------------------------------* +* fonction calculant la vitesse de chute d'une particule de rayon* +* k se trouvant a l'altitude j suivant la valeur du nombre de * +* Knudsen * +* indic ....... idem function lambda * +*-----------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +* declaration des variables internes +* ---------------------------------- + + integer indic,j,k + real w,g,m,a0,zz,nud,knud,tt,rhoh + real rbis, rfk,vb,zbx + real akncx,knu + +* traitement +* ---------- + + if (indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction vitesse' + return + endif + + if(indic.eq.0) then + zz=z(j)+dz(j)/2. + tt=tb(j) + rhoh=rhob(j) + endif + if(indic.eq.1) then + zz=z(j) + tt=t(j) + rhoh=rho(j) + endif + + g=g0*(rtit/(rtit+zz))**2 + a0=0.74 + m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav + knud=knu(j,k,indic) + + + rfk=(r_e(k)**(3./df(k)))*((rf(k))**(1.-3./df(k))) +c rfk=r_e(7) + + + w=2./9.*rfk**(df(k)-1.)*rf(k)**(3.-df(k))*g*rhol/nud(j,indic) + + w=w*(1+1.2517*knud+0.4*knud*exp(-1.1/knud)) + + +c if (p(j).lt.500..and.k.eq.nrad) then +c w=0. +c endif + + vitesse=w + + end +*********************************************************************** + + real function kd(h) +* +*--------------------------------------------------------------------* +* cette fonction calcule le coefficient du terme de 'eddy diffusion'* +* a l altitude j * +*--------------------------------------------------------------------* +* + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + real zbx + + integer h + + zbx=z(h)+dz(h)/2. + +c ATTENTION !! +c toutes ces definitions sont contradictoires, +c pour mettre 0 au bout du compte... +c A NETTOYER !! + + if(zbx.le.42000.) then + kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + kd=4. + else + kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + endif + + if(zbx.le.50000.) then + kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + endif + + kd=0.0*kd + + return + end + + +*____________________________________________________________________________ + + subroutine init +* +*--------------------------------------------------------------------* +* cette routine effectue : * +* 1) interpolation a partir des donnees initiales des * +* valeurs de p,t,rho,ach4,aar,an2 sur la grille * +* 2) initialisation des constantes (common/phys/) * +* 3) initialisation des variables temporelles (common * +* /temps/) * +* 4) definition des grilles en rayon et verticale * +* 5) initialisation de c(z,r,t) avec les donnees du * +* fichier unit=1 * +* * +* les donnees sont des valeurs caracterisques de l'atmosphere de * +* TITAN ( voir Lelouch and co ) * +*--------------------------------------------------------------------* + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + + common/ctps/li,lf,dt + common/con/c + +* declaration des variables communes +* ---------------------------------- + + real c(nz,nrad,2) + integer li,lf + integer i,ii + real dt + +* declaration des variables internes +* ---------------------------------- + + integer nzd + parameter (nzd=254) + integer limsup,liminf,j1,j2 + real zd(nzd),ach4d(nzd),rap + real m + + +* initialisation des variables temporelles +* ---------------------------------------- + + li=1 + lf=2 + + +* interpolation de xch4,xar et xn2 sur la grille +* ---------------------------------------------- + +* donnees initiales (Lellouch et al,87) +* ------------------------------------- + +c print*,'****** init' + do 1 i=1,168 + zd(i)=(1000.-5*(i-1))*1000. +1 continue + do 2 i=1,78 + zd(168+i)=(160.-2*(i-1))*1000. +2 continue + do 3 i=1,4 + zd(246+i)=(5.-(i-1))*1000. +3 continue + do 4 i=1,4 + zd(250+i)=(1.5-(i-1)*0.5)*1000. +4 continue + + data (ach4d(i),i=1,168)/168*1.5e-2/ + data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2, + & 1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2, + & 4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/ + + liminf=0 + limsup=0 + +* interpolation des taux de melange de ch4,ar,n2 +*----------------------------------------------- + +! do 20 j1=1,nz +! do 21 j2=1,nzd +! if( zd(j2).le.z(j1)) goto 22 +!21 continue +!22 liminf=j2 + + do 20 j1=1,nz + do 21 j2=1,nzd + if( zd(j2).le.z(j1)) goto 22 + 21 continue + 22 if (j2.ge.254) j2=254 + liminf = j2 + + if (zd(liminf).eq.z(j1) )then + ach4(j1)=ach4d(liminf) + goto 20 + endif + if (j2.ne.1) then + limsup=j2-1 + else + limsup=j2 + endif + + if (limsup.eq.liminf) then + ach4(j1)=ach4(limsup) + else + ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/ + s (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1)) + endif +20 continue + +* rap= aar/an2 cst sur l'altitude + + rap=0.02 +c rap=0.191 + do 23 i=1,nz + an2(i)=(1.-ach4(i))/(1.+rap) + aar(i)=rap*an2(i) +23 continue + + do 24 i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rho(i)=p(i)*m/(rgp*t(i)) +24 continue + + do i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rhob(i)=pb(i)*m/(rgp*tb(i)) +c print*,pb(i),m,rgp,tb(i),rhob(i),rho(i) + enddo + +* fin d'interpolation des taux de melange +*---------------------------------------- + +c print*,'**** fin init' +540 continue + return + +500 print*,'erreur lecture initialisation de c...erreur=',ii + stop + + end + +*____________________________________________________________________________ + + subroutine pertpro(h,a,l_,pr_) + +***************************************************************************** +* * +* ce programme permet le calcul du terme de production (pr) et de perte (l)* +* pour le phenomene de coagulation * +* dans le a ieme intervalle de rayon a une altitude h * +***************************************************************************** + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + + common/ctps/li,lf,dt + common/con/c + common/coag/k + +* declaration des variables +* -------------------------- + + integer li,lf + real dt + real c(nz,nrad,2),k(nz,nrad,nrad) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,a,x,i + real*8 pr,ss,s,l + real pr_,l_,vol,del + +* traitement +* ----------- + +* production +*+++++++++++++ + s=0.d0 + ss=0.d0 + pr=0. + + if (a .eq. 1) goto 2 + b=a-1 + + if (c(h,b,lf) .eq. 0 .and. c(h,b,li) .eq. 0) goto 2 + + do 1 i=1,b + + if(c(h,i,li) .eq. 0 .and. c(h,i,lf) .eq. 0) goto 1 + + if (i .ne. b)del=1. + if (i .eq. b) del=.5 + + s=(v_e(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,li)*1.d0)+s + ss=(v_e(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,lf)*1.d0)+ss + +c if (a.eq.2) print*,'SS>',v_e(i),k(h,b,i),c(h,b,lf) +c if (a.eq.2) print*,'SS>',del*v_e(i)*k(h,b,i)*c(h,b,lf) + + +1 continue + +* calcul du terme de production + + pr=(c(h,b,lf)*s/(vrat_e-1.)+c(h,b,li)*ss)/v_e(a) +c if (a.eq.2) print*,'PR>',s,ss,c(h,b,lf),v_e(a) + +2 continue + + +* perte +*- - - - - + + l=0 + + +* condition limite : pas de perte dans le dernier intervalle + + if (a .eq. nrad) goto 9 + + do 10 x=1,nrad + + if (c(h,x,li) .eq. 0) goto 10 + + if (a .lt. x) vol=1. + if (a .eq. x) vol=.5*vrat_e/(vrat_e-1) + if (a .gt. x) vol=v_e(x)/(v_e(a)*(vrat_e-1)) + + l=l+k(h,a,x)*c(h,x,li)*vol*1.d0 + + +10 continue +9 continue + +#ifdef CRAY + l_=l + pr_=pr +#else + l_=sngl(l) + pr_=sngl(pr) +#endif +c l_=sngl(l) +c pr_=sngl(pr) +c if (a.eq.2) print*,'pr_,l_',h,a,pr_,l_ +c if (a.eq.2) print*,'-----------------------' +c if (a.eq.2) STOP + + + + return + + end + +*_____________________________________________________________________________ + + subroutine production(ihor) +* +*--------------------------------------------------------------------* +* routine calculant le terme de production des molecules organiques * +* composant les aerosols . rini= rayon des aerosols initiaux * +*--------------------------------------------------------------------* +* + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" +#include "clesphys.h" + +c#include "aerprod.h" + + + integer ndz,i,ihor,k,k1 + real c(nz,nrad,2) + integer li,lf + real dt + real zprod,zy,c0,ctot,prod,rini,rfron + real xsaison,p0 + common/ctps/li,lf,dt + common /con/c + common/effets/xsaison + +! Pressure level of aerosol production + p0=p_prodaer + + do i=1,nz-1 + if (pb(i).lt.p0.and.pb(i+1).gt.p0) zprod=(z(i)+z(i+1))/2. + enddo + + ctot=3.5e-13*tx ! ATTENTION, ??COHERENT AVEC INITPAR?? + ctot=ctot*xsaison ! + +c z0=385.e+3 + zy=20.e+3 + rini=1.3e-9 + rini=r_e(1) + ndz=50 +* + do 10 i=1,nrad + if(rini.lt.r_e(i)) goto 100 +10 continue +100 continue + if (i.eq.1) then + rini=r_e(1) + else + rfron=(r_e(i)+r_e(i-1))/2 + if (rini .lt.rfron) then + rini=r_e(i-1) + i=i-1 + else + rini=r_e(i) + endif + endif +* + c0=ctot/(sqrt(2.*pi)*zy) + c0=c0*3./(4.*pi*rhol*rini**3) +* + do 20 k=nztop,nz + prod=0. + do 201 k1=1,ndz + prod=prod+c0*exp(-0.5*(((z(k)+dz(k)/2.-k1*dz(k)/(2.*ndz) + s -zprod)/zy)**2))*dt/ndz +201 continue + + if (prod .le. 1) prod=0. + c(k,i,lf)=c(k,i,lf)+prod +20 continue + +! do 30 k=nztop,nz +! c(k,i,lf)=c(k,i,lf)+prodaer(ihor,nz-k+1,1) +! & *3./(4.*pi*rhol*rini**3) +!30 continue + + return + end + +*-------------------------------------------------------------------* + + + + subroutine sedif(dice3) +* +*------------------------------------------------------------------* +* cette routine calcule l'evolution de la fonction de distribution* +* c(z,r,t) pour les phenomenes de sedimentation et de diffusion * +*------------------------------------------------------------------* +* +* +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/ctps/li,lf,dt + common/con/c + +* declaration des variables communes +* ---------------------------------- + + integer li,lf + integer i,j,k,nb + real dt + real c(nz,nrad,2),dice3,bilan4,bilan14 + +* declaration des variables internes +* ---------------------------------- + + real w,w1,dzbX,dc + double precision sigma,theta,hc,l,rap,cmp,wp + double precision fs(nz+1),ft(nz+1) + real as(nz),bs(nz),cs(nz),ds(nz) + double precision asi(nztop:nz),bsi(nztop:nz), + & csi(nztop:nz) + double precision dsi(nztop:nz),xsol(nztop:nz) + real vitesse,kd + + external dtridgl +* resolution +*------------ + + + bilan4=0. + do k=1,nrad + do j=nztop,nz + bilan4=bilan4+c(j,k,li)*dzb(j)* + & 4./3.*pi*rf(k)**3.*vrat_e**(k-imono) + enddo + enddo + + + do 10 k=1,nrad + do 20 j=nztop,nz + + if (j.eq.1) goto 20 + +* calcul de la vitesse corrigee + + dzbX=(dz(j)+dz(j-1))/2. + w=-1*vitesse(j,k,0) + if (kd(j).ne.0.) then + theta=0.5*(w*dzbX/kd(j)+log(rho(j-1)/rho(j))) + if (theta.ne.0) then + sigma=1./dtanh(theta)-1./theta + else + sigma=1. + endif + else + sigma=1. + endif + if(c(j,k,li).eq.0.) then + rap=10. + else + rap=c(j-1,k,li)/c(j,k,li) + if( rap.gt.10.) rap=10. + if( rap.lt.0.1) rap=0.1 + endif + if (rap.gt.0.9 .and. rap.lt.1.1) then + w1=w + else + if(w.ne.0) then + hc=dzbX/dlog(rap) + l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap) + wp=w*1.d0 + cmp=dlog(-wp)+abs(sigma)*dlog(l) + if (cmp.gt.38) then + goto 20 + endif + w1=-dexp(cmp) + + else + w1=0. + endif + endif + +c if(w1.ge.0. .or. w1.le.0.) then +c continue +c else +c print*,j,k,w1,hc,dzbx,rap,dlog(rap),' w1' +c endif + +* calcul des flux aux interfaces + + + if (kd(j).ne.0.) then + if (theta.ne.0.) then + ft(j)=(w1+log(rho(j-1)/rho(j))*kd(j)/dzbX)/(dexp(2.* + s theta)-1.) + fs(j)=ft(j)*dexp(2.*theta) + else + ft(j)=kd(j)/dzbX + fs(j)=kd(j)/dzbX + endif + else + if (w1.lt.0.)then + ft(j)=-w1 + fs(j)=0. + else + ft(j)=0. + fs(j)=w1 + endif + endif + +20 continue + +* conditions aux limites pour les flux aux interfaces + + fs(1)=0. + ft(1)=0. + fs(nz+1)=0. + ft(nz+1)=-w1 + +* calcul des coefficients de l'equation discrete + + do 21 j=nztop,nz + as(j)=-dz(j)/dt + bs(j)=-ft(j) + cs(j)=ft(j+1)+fs(j)-dz(j)/dt + ds(j)=-fs(j+1) + + if ( cs(j).gt.0) goto 100 +21 continue + +* cas explicite (mu=0) : calcul de la fonction c(z,r,t+1) + + do 22 j=nztop,nz-1 + + if (j.eq.nztop) then + dc=(cs(nztop)*c(nztop,k,li)+ds(nztop) + & *c(nztop+1,k,li))/as(nztop) + c(nztop,k,lf)=dc + goto 22 + endif + + dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li)) + s /as(j) + c(j,k,lf)=dc + + +22 continue + + dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz) + c(nz,k,lf)=dc + + if (nztop.ne.1) then + do 32 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +32 continue + endif + + goto 10 + +100 continue + +* cas implicite (mu=1) : calcul de la fonction c(z,r,t+1) + + do 101 j=nztop,nz + asi(j)=ft(j) + bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt) + csi(j)=fs(j+1) + dsi(j)=-dz(j)/dt*c(j,k,li) + xsol(j)=0. +101 continue + +* inversion de la matrice tridiagonale + + nb=nz-nztop+1 + + call dtridgl(nb,asi,bsi,csi,dsi,xsol) + + + do 102 j=nztop,nz + c(j,k,lf)=xsol(j) +102 continue + + if (nztop.ne.1) then + do 110 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +110 continue + endif + + + +10 continue + + bilan14=0. + do k=1,nrad + do j=nztop,nz + bilan14=bilan14+c(j,k,lf)*dzb(j)* + & 4./3.*pi*rf(k)**3.*vrat_e**(k-imono) + enddo + enddo + + + dice3=(bilan14-bilan4)*rhol + + + return + + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/calchim.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/calchim.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/calchim.F (revision 1643) @@ -0,0 +1,602 @@ + SUBROUTINE calchim(nlon,ny,qy_c,nomqy_c,declin_rad,ls_rad,dtchim, + . ctemp,cplay,cplev,czlay,czlev, + . dqyc) + +c------------------------------------------------- +c +c Introduction d une routine chimique +c +c Auteur: S. Lebonnois, 01/2000 | 09/2003 +c adaptation pour Titan 3D: 02/2009 +c adaptation pour // : 04/2013 +c extension chimie jusqu a 1300km : 10/2013 +c +c------------------------------------------------- +c + use dimphy + use common_mod, only:utilaer,maer,prodaer,csn,csh,psurfhaze, + . NLEV,NLRT,NC,ND,NR + USE moyzon_mod, only: tmoy,playmoy,zlaymoy,zlevmoy,klat + use mod_grid_phy_lmdz, only: nbp_lat + implicit none +#include "clesphys.h" +#include "YOMCST.h" + +c Arguments +c --------- + + INTEGER nlon ! nb of horiz points + INTEGER ny ! nb de composes (nqmax-nmicro) + REAL qy_c(nlon,klev,NC) ! Especes chimiques apres adv.+diss. + character*10 nomqy_c(NC+1) ! Noms des especes chimiques + REAL declin_rad,ls_rad ! declinaison et long solaire en radians + REAL dtchim ! pas de temps chimie + REAL ctemp(nlon,klev) ! Temperature + REAL cplay(nlon,klev) ! pression (Pa) + REAL cplev(nlon,klev+1) ! pression intercouches (Pa) + REAL czlay(nlon,klev) ! altitude (m) + REAL czlev(nlon,klev+1) ! altitude intercouches (m) + + REAL dqyc(nlon,klev,NC) ! Tendances especes chimiques + +c Local variables : +c ----------------- + + integer i,j,l,ic,jm1 + +c variables envoyees dans la chimie: double precision + + REAL temp_c(NLEV) + REAL press_c(NLEV) ! T,p(mbar) a 1 lat donnee + REAL cqy(NLEV,NC) ! frac mol qui seront modifiees + REAL cqy0(NLEV,NC) ! frac mol avant modif + REAL surfhaze(NLEV) + REAL cprodaer(NLEV,4),cmaer(NLEV,4) + REAL ccsn(NLEV,4),ccsh(NLEV,4) +! rmil: milieu de couche, grille pour K,D,p,ct,T,y +! rinter: intercouche (grille RA dans la chimie) + REAL rmil(NLEV),rinter(NLEV),nb(NLEV) + REAL,save :: kedd(NLEV) + + REAL a,b + character str1*1,str2*2 + REAL latit + character*20 formt1,formt2,formt3 + +c variables locales initialisees au premier appel + + LOGICAL firstcal + DATA firstcal/.true./ + SAVE firstcal + + integer dec,declinint,ialt + REAL declin_c ! declinaison en degres + real factalt,factdec,krpddec,krpddecp1,krpddecm1 + real duree + REAL,save :: mass(NC) + REAL,save,allocatable :: md(:,:) + REAL,save :: botCH4 + DATA botCH4/0.05/ + real,save :: r1d(131),ct1d(131),p1d(131),t1d(131) ! lecture tcp.ver + REAL,save,allocatable :: krpd(:,:,:,:),krate(:,:) + integer,save :: reactif(5,NR),nom_prod(NC),nom_perte(NC) + integer,save :: prod(200,NC),perte(2,200,NC) + character dummy*30,fich*7,ficdec*15,curdec*15,name*10 + real ficalt,oldq,newq,zalt + logical okfic + +c----------------------------------------------------------------------- +c*********************************************************************** +c +c Initialisations : +c ---------------- + + duree = dtchim ! passage en real*4 pour appel a routines C + + IF (firstcal) THEN + + print*,'CHIMIE, premier appel' + +c ************************************ +c Au premier appel, initialisation de toutes les variables +c pour les routines de la chimie. +c ************************************ + + allocate(krpd(15,ND+1,NLRT,nbp_lat),krate(NLEV,NR),md(NLEV,NC)) + +c Verification du nombre de composes: coherence common_mod et nqmax-nmicro +c ---------------------------------- + + if (ny.ne.NC) then + print*,'PROBLEME de coherence dans le nombre de composes:' + . ,ny,NC + STOP + endif + +c calcul de temp_c, densites et press_c en moyenne planetaire : +c -------------------------------------------------------------- + + print*,'pression, densites et temp (init chimie):' + print*,'level, press_c, nb, temp_c' + DO l=1,klev + rinter(l) = (zlevmoy(l)+RA)/1000. + rmil(l) = (zlaymoy(l)+RA)/1000. +c temp_c (K): + temp_c(l) = tmoy(l) +c press_c (mbar): + press_c(l) = playmoy(l)/100. +c nb (cm-3): + nb(l) = 1.e-4*press_c(l) / (RKBOL*temp_c(l)) + print*,l,rmil(l)-RA/1000.,press_c(l),nb(l),temp_c(l) + ENDDO + rinter(klev+1)=(zlevmoy(klev+1)+RA)/1000. + +c au-dessus du GCM, dr regulier et rinter(NLEV)=1290+2575 km. + do l=klev+2,NLEV + rinter(l) = rinter(klev+1) + & + (l-klev-1)*(3865.-rinter(klev+1))/(NLEV-klev-1) + rmil(l-1) = (rinter(l-1)+rinter(l))/2. + enddo + rmil(NLEV) = rinter(NLEV)+(rinter(NLEV)-rinter(NLEV-1))/2. + +c lecture de tcp.ver, une seule fois +c remplissage r1d,t1d,ct1d,p1d + open(11,file='../../INPUT/tcp.ver',status='old') + read(11,*) dummy + do i=1,131 + read(11,*) r1d(i),t1d(i),ct1d(i),p1d(i) +c print*,"TCP.VER ",r1d(i),t1d(i),ct1d(i),p1d(i) + enddo + close(11) + +c extension pour klev+1 a NLEV avec tcp.ver +c la jonction klev/klev+1 est brutale... Tant pis ? + ialt=1 + do l=klev+1,NLEV + zalt=rmil(l)-RA/1000. + do i=ialt,130 + if ((zalt.ge.r1d(i)).and.(zalt.lt.r1d(i+1))) then + ialt=i + endif + enddo + factalt = (zalt-r1d(ialt))/(r1d(ialt+1)-r1d(ialt)) + press_c(l) = exp( log(p1d(ialt)) * (1-factalt) + & + log(p1d(ialt+1)) * factalt ) + nb(l) = exp( log(ct1d(ialt)) * (1-factalt) + & + log(ct1d(ialt+1)) * factalt ) + temp_c(l) = t1d(ialt) * (1-factalt) + t1d(ialt+1) * factalt + print*,l,zalt,press_c(l),nb(l),temp_c(l) + enddo + +c caracteristiques des composes: +c ----------------------------- + mass(:) = 0.0 + call comp(nomqy_c,nb,temp_c,mass,md) + print*,' Mass' + do ic=1,NC + print*,nomqy_c(ic),mass(ic) +c if(nomqy_c(ic).eq.'CH4') print*,"MD=",md(:,ic) + enddo + + +c Stockage des composes utilises dans la prod d aerosols +c (aerprod=1) et dans H-> H2 (htoh2=1): utilaer +c ! decalage de 1 car utilise dans le c ! + + do ic=1,NC + +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c!!!remise de CH4 a 1.5%!!!!!!!!!!!!!!!!!!!!!! +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c if (nomqy_c(ic).eq."CH4") then +c do l=1,llm +c do j=1,ip1jmp1 +c if (qy_c(j,l,ic).le.0.015) qy_c(j,l,ic) = 0.015 +c enddo +c enddo +c endif +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (nomqy_c(ic).eq."C4H2") then + utilaer(10) = ic-1 + endif + if (nomqy_c(ic).eq."HCN") then + utilaer(6) = ic-1 + endif + if (nomqy_c(ic).eq."HC3N") then + utilaer(7) = ic-1 + endif + if (nomqy_c(ic).eq."NCCN") then + utilaer(14) = ic-1 + endif + if (nomqy_c(ic).eq."CH3CN") then + utilaer(15) = ic-1 + utilaer(16) = ic-1 ! si pas C2H3CN, CH3CN utilise, mais reac. nulle + endif + if (nomqy_c(ic).eq."H") then + utilaer(1) = ic-1 + endif + if (nomqy_c(ic).eq."H2") then + utilaer(2) = ic-1 + endif + if (nomqy_c(ic).eq."C2H2") then + utilaer(3) = ic-1 + endif + if (nomqy_c(ic).eq."AC6H6") then + utilaer(13) = ic-1 + endif + if (nomqy_c(ic).eq."C2H3CN") then + utilaer(16) = ic-1 + endif + if (nomqy_c(ic).eq."C2") then + utilaer(4) = ic-1 + endif + if (nomqy_c(ic).eq."C2H") then + utilaer(5) = ic-1 + endif + if (nomqy_c(ic).eq."C3N") then + utilaer(8) = ic-1 + endif + if (nomqy_c(ic).eq."H2CN") then + utilaer(9) = ic-1 + endif + if (nomqy_c(ic).eq."C4H3") then + utilaer(11) = ic-1 + endif + if (nomqy_c(ic).eq."AC6H5") then + utilaer(12) = ic-1 + endif + +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c if ((nomqy_c(ic).eq."HC3N").or. +c $ (nomqy_c(ic).eq."C3N")) then +c DO j=1,ip1jmp1 +c do l=1,34 ! p>~ 1 mbar +c qy_c(j,l,ic) = 1.e-30 +c enddo +c ENDDO +c endif +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + enddo + +c taux de photodissociations: +c -------------------------- + call disso(krpd,nbp_lat) + +c reactions chimiques: +c ------------------- + call chimie(nomqy_c,nb,temp_c,krate,reactif, + . nom_perte,nom_prod,perte,prod) +c print*,'nom_prod, nom_perte:' +c do ic=1,NC +c print*,nom_prod(ic),nom_perte(ic) +c enddo +c print*,'premieres prod, perte(1:reaction,2:compagnon):' +c do ic=1,NC +c print*,prod(1,ic),perte(1,1,ic),perte(2,1,ic) +c enddo + +c l = klev-3 +c print*,'krate a p=',press_c(l),' reactifs et produits:' +c do ic=1,ND+1 +c print*,ic,krpd(7,ic,l,4)*nb(l)," ", +c . nomqy_c(reactif(1,ic)+1), +c . nomqy_c(reactif(2,ic)+1),nomqy_c(reactif(3,ic)+1), +c . nomqy_c(reactif(4,ic)+1),nomqy_c(reactif(5,ic)+1) +c enddo +c do ic=ND+2,NR +c print*,ic,krate(l,ic)," ", +c . nomqy_c(reactif(1,ic)+1), +c . nomqy_c(reactif(2,ic)+1),nomqy_c(reactif(3,ic)+1), +c . nomqy_c(reactif(4,ic)+1),nomqy_c(reactif(5,ic)+1) +c enddo + + +c init kedd +c --------- +c kedd stays constant with time and space +c => linked to pressure rather than altitude... + + kedd(:) = 5e2 ! valeur mise par defaut + ! UNITE ? doit etre ok pour gptitan + do l=1,NLEV + zalt=rmil(l)-RA/1000. ! z en km + if ((zalt.ge.250.).and.(zalt.le.400.)) then + kedd(l) = 10.**(3.+(zalt-250.)/50.) +! 1E3 at 250 km +! 1E6 at 400 km + elseif ((zalt.gt.400.).and.(zalt.le.600.)) then + kedd(l) = 10.**(6.+1.3*(zalt-400.)/200.) +! 2E7 at 600 km + elseif ((zalt.gt.600.).and.(zalt.le.900.)) then + kedd(l) = 10.**(7.3+0.7*(zalt-600.)/300.) +! 1E8 above 900 km + elseif ( zalt.gt.900. ) then + kedd(l) = 1.e8 + endif + enddo + + ENDIF ! premier appel + +c*********************************************************************** +c----------------------------------------------------------------------- + +c calcul declin_c (en degres) +c --------------------------- + + declin_c = declin_rad*180./RPI +c print*,'declinaison en degre=',declin_c + +c*********************************************************************** +c*********************************************************************** +c +c BOUCLE SUR LES LATITUDES +c + DO j=1,nlon + + if (j.eq.1) then + jm1=1 + else + jm1=j-1 + endif + + if((j.eq.1).or.(klat(j).ne.klat(jm1))) then + +c*********************************************************************** +c*********************************************************************** + +c----------------------------------------------------------------------- +c +c Distance radiale (intercouches, en km) +c ---------------------------------------- + + do l=1,klev + rinter(l) = (RA+czlev(j,l))/1000. + rmil(l) = (RA+czlay(j,l))/1000. +c print*,rinter(l) + enddo + rinter(klev+1)=(RA+czlev(j,klev+1))/1000. + +c au-dessus du GCM, dr regulier et rinter(NLEV)=1290+2575 km. + do l=klev+2,NLEV + rinter(l) = rinter(klev+1) + & + (l-klev-1)*(3865.-rinter(klev+1))/(NLEV-klev-1) + rmil(l-1) = (rinter(l-1)+rinter(l))/2. + enddo + rmil(NLEV) = rinter(NLEV)+(rinter(NLEV)-rinter(NLEV-1))/2. + +c----------------------------------------------------------------------- +c +c Temperature, pression (mbar), densite (cm-3) +c ------------------------------------------- + + DO l=1,klev +c temp_c (K): + temp_c(l) = ctemp(j,l) +c press_c (mbar): + press_c(l) = cplay(j,l)/100. +c nb (cm-3): + nb(l) = 1.e-4*press_c(l) / (RKBOL*temp_c(l)) + ENDDO +c extension pour klev+1 a NLEV avec tcp.ver + ialt=1 + do l=klev+1,NLEV + zalt=rmil(l)-RA/1000. + do i=ialt,130 + if ((zalt.ge.r1d(i)).and.(zalt.lt.r1d(i+1))) then + ialt=i + endif + enddo + factalt = (zalt-r1d(ialt))/(r1d(ialt+1)-r1d(ialt)) + press_c(l) = exp( log(p1d(ialt)) * (1-factalt) + & + log(p1d(ialt+1)) * factalt ) + nb(l) = exp( log(ct1d(ialt)) * (1-factalt) + & + log(ct1d(ialt+1)) * factalt ) + temp_c(l) = t1d(ialt) * (1-factalt) + t1d(ialt+1) * factalt + enddo + +c----------------------------------------------------------------------- +c +c passage krpd => krate +c --------------------- +c initialisation krate pour dissociations + + if ((declin_c*10+267).lt.14.) then + declinint = 0 + dec = 0 + else + if ((declin_c*10+267).gt.520.) then + declinint = 14 + dec = 534 + else + declinint = 1 + dec = 27 + do while( (declin_c*10+267).ge.real(dec+20) ) + dec = dec+40 + declinint = declinint+1 + enddo + endif + endif + if ((declin_c.ge.-24.).and.(declin_c.le.24.)) then + factdec = ( declin_c - (dec-267)/10. ) / 4. + else + factdec = ( declin_c - (dec-267)/10. ) / 2.7 + endif + + do l=1,NLEV + +c INTERPOL EN ALT POUR k (krpd tous les deux km) + ialt = int((rmil(l)-RA/1000.)/2.)+1 + factalt = (rmil(l)-RA/1000.)/2.-(ialt-1) + + do i=1,ND+1 + krpddecm1 = krpd(declinint ,i,ialt ,klat(j)) * (1-factalt) + & + krpd(declinint ,i,ialt+1,klat(j)) * factalt + krpddec = krpd(declinint+1,i,ialt ,klat(j)) * (1-factalt) + & + krpd(declinint+1,i,ialt+1,klat(j)) * factalt + krpddecp1 = krpd(declinint+2,i,ialt ,klat(j)) * (1-factalt) + & + krpd(declinint+2,i,ialt+1,klat(j)) * factalt + + ! ND+1 correspond a la dissociation de N2 par les GCR + if ( factdec.lt.0. ) then + krate(l,i) = krpddecm1 * abs(factdec) + & + krpddec * ( 1 + factdec) + endif + if ( factdec.gt.0. ) then + krate(l,i) = krpddecp1 * factdec + & + krpddec * ( 1 - factdec) + endif + if ( factdec.eq.0. ) krate(l,i) = krpddec + enddo + enddo + +c----------------------------------------------------------------------- +c +c composition +c ------------ + + do ic=1,NC + do l=1,klev + cqy(l,ic) = qy_c(j,l,ic) + cqy0(l,ic) = cqy(l,ic) + enddo + enddo + +c lecture du fichier compo_klat(j) (01 à 49) pour klev+1 a NLEV + + WRITE(str2,'(i2.2)') klat(j) + fich = "comp_"//str2//".dat" + inquire (file=fich,exist=okfic) + if (okfic) then + open(11,file=fich,status='old') +c premiere ligne=declin + read(11,'(A15)') ficdec + write(curdec,'(E15.5)') declin_c +c si la declin est la meme: ce fichier a deja ete reecrit +c on lit la colonne t-1 au lieu de la colonne t +c (cas d une bande de latitude partagee par 2 procs) + do ic=1,NC + read(11,'(A10)') name + if (name.ne.nomqy_c(ic)) then + print*,"probleme lecture ",fich + print*,name,nomqy_c(ic) + stop + endif + if (ficdec.eq.curdec) then + do l=klev+1,NLEV + read(11,*) ficalt,cqy(l,ic),newq + enddo + else + do l=klev+1,NLEV + read(11,*) ficalt,oldq,cqy(l,ic) + enddo + endif + enddo + close(11) + else ! le fichier n'est pas la + do ic=1,NC + do l=klev+1,NLEV + cqy(l,ic)=cqy(klev,ic) + enddo + enddo + endif + cqy0 = cqy + +c----------------------------------------------------------------------- +c +c total haze area (um2/cm3) +c ------------------------- + + if (htoh2.eq.1) then + do l=1,klev +! ATTENTION, INVERSION PAR RAPPORT A pg2.F !!! + surfhaze(l) = psurfhaze(j,klev+1-l) +c if (j.eq.25) +c . print*,'psurfhaze en um2/cm3:',surfhaze(l) + enddo + endif + +c----------------------------------------------------------------------- +c +c Appel de chimietitan +c -------------------- + + call gptitan(rinter,temp_c,nb, + $ nomqy_c,cqy, + $ duree,(klat(j)-1),mass,md, + $ kedd,botCH4,krate,reactif, + $ nom_prod,nom_perte,prod,perte, + $ aerprod,utilaer,cmaer,cprodaer,ccsn,ccsh, + $ htoh2,surfhaze) + +c Tendances composition +c --------------------- + + do ic=1,NC + do l=1,klev + dqyc(j,l,ic) = (cqy(l,ic) - cqy0(l,ic))/dtchim ! en /s + enddo + enddo + +c----------------------------------------------------------------------- +c +c production aer +c -------------- + + if (aerprod.eq.1) then + + do ic=1,4 + do l=1,klev + prodaer(j,l,ic) = cprodaer(l,ic) + maer(j,l,ic) = cmaer(l,ic) + csn(j,l,ic) = ccsn(l,ic) + csh(j,l,ic) = ccsh(l,ic) + enddo + enddo + + endif + +c----------------------------------------------------------------------- +c +c sauvegarde compo sur NLEV +c ------------------------- + +c dans fichier compo_klat(j) (01 à 49) + + open(11,file=fich,status='replace') +c premiere ligne=declin + write(11,'(E15.5)') declin_c + do ic=1,NC + write(11,'(A10)') nomqy_c(ic) + do l=klev+1,NLEV + write(11,'(E15.5,1X,E15.5,1X,E15.5)') rmil(l)-RA/1000., + . cqy0(l,ic),cqy(l,ic) + enddo + enddo + close(11) + +c*********************************************************************** +c*********************************************************************** + +c FIN: BOUCLE SUR LES LATITUDES + + else ! same latitude, we don't do calculations again + dqyc(j,:,:) = dqyc(jm1,:,:) + if (aerprod.eq.1) then + prodaer(j,:,:) = prodaer(jm1,:,:) + maer(j,:,:) = maer(jm1,:,:) + csn(j,:,:) = csn(jm1,:,:) + csh(j,:,:) = csh(jm1,:,:) + endif + endif + + ENDDO + +c*********************************************************************** +c*********************************************************************** + + + firstcal = .false. + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/cfffv11.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cfffv11.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cfffv11.F (revision 1643) @@ -0,0 +1,1117 @@ + subroutine cfffv11(lambda,xn,xk,rad,DFS,NB,fsca,fext,fabs,fg) +* +* NEW VERSION MARCH, 31, 1999. +* WITHOUT MAXWELL-GARNETT APPROACH FOR IM{M} > 0.1 +* + + + parameter (nang=91) + + complex mtest,refrel,s1(2000),s2(2000) + real rad,lambda,s11(2000),theta(10000) + real s110u(2000),s111u(2000) + real s110d(2000),s111d(2000) + real pol(2000),pp(2,2000),strS(2000) + real NB + real xxn + +* COMMON WITH INTMIE + + common/angle11/theta + +* COMMON WITH CORRINT11 + + common/pack1/cjup1,cju,cjup1_,cju_,xrap,xechj,xechjp1 + common/pack2/cjdp1,cjd,cjdp1_,cjd_,xku,xkd,jindex + common/pack3/xexp5,xexp6 + +* COMMON WITH FFFV11 + + DATA IND /0/ + + + if(nang*2.gt.2000) + & stop 'INCREASE THE SIZE OF THE ARRAYS IN CFFFV11' + +c refrel=(xn,xk) + refrel=cmplx(xn,xk) + nindex=int(xn*100.) + x=2.*3.14159265*rad/lambda + dang=1.570796327/dfloat(nang-1) + pi=3.14159265 + NC=20 + DF=1.99999 + alpha=1.1 + alphaS=(1.4-1.1)/(2.5-2.)*DFS-.1 !APPROXIMATED! + !EXACT FOR D=2 AND 2.5! + +****************************************************************** +* STEP # 1 +****************************************************************** +* CALL THE ROUTINE THAT GIVE THE SCALING FACTOR'S PSI_s AND PSI_e +* FOR EACH BOUND OF THE INTERVAL nX(j) < n*X < nX(j+1) AND +* xku < xk < xkd. +* THESE FACTORS ARE GIVEN ASSUMING : N=20, DF=2 AND KNOWING n +* +* NB: HERE PSI ARE NOTED cju,cjd,cjup1,cjdp1..... +****************************************************************** + + call corrint11(x,xn,xk,NC) + + +****************************************************************** +* STEP # 2 +****************************************************************** +* FOR EACH OF THE FOUR "POINTS" (nX,k), COMPUTE THE MIE CROSS-SECTIONS +* AND PHASE FUNCTION FOR A SPHERE AS ONE MONOMER. +* DERIVE, THANKS TO THE PSI, THE MONOMER CROSS-SECTIONS +* COMPUTE ALSO THE ACTUAL MIE CROSS SECTION (I.E FOR THE ACTUAL +* VALUES OF n,X and k) +****************************************************************** + +* STEP #2.1 +****************************************** +* if Mie & monomer in Rayleigh scattering: +****************************************** +* the phase function shape does not depends +* on x neither the PSI's: for each values of +* k, only one computation is to be done +***************************************** + + IF (x*xn.le.0.085) THEN + + +* pour k=xku +* # x=xech(j) +* # x=xech(j+1) + +c refrel=(xn,xku) + refrel=cmplx(xn,xku) + + call intmie(x,refrel,nang,s1,s2,qext_,qsca_) + qsca1u=alog10(qsca_*400.) + qext1u=alog10(qext_*20.) + qsca2u=alog10(qsca_*400.) + qext2u=alog10(qext_*20.) + +* pour k=xkd +* # x=xech(j) +* # x=xech(j+1) + +c refrel=(xn,xkd) + refrel=cmplx(xn,xkd) + + call intmie(x,refrel,nang,s1,s2,qext_,qsca_) + qsca1d=alog10(qsca_*400.) + qext1d=alog10(qext_*20.) + qsca2d=alog10(qsca_*400.) + qext2d=alog10(qext_*20.) + + xrap=0. + +* Mie exact +* + +c refrel=(xn,xk) + refrel=cmplx(xn,xk) + + call intmie(x,refrel,nang,s1,s2,qext_,qsca_) + do j=1,2*nang-1 + s11(j)=cabs(s2(j))*cabs(s2(j))+cabs(s1(j))*cabs(s1(j)) + s11(j)=s11(j)/(2.*pi*x**2.*qsca_) + enddo + + + ELSE + +* STEP #2.2 +************************************************ +* if Mie & monomer in the range X about 1 to 5 * +************************************************ + +* pour k=xkd +* # x=xech(j) +* # x=xech(j+1) + + + qsca1d=alog10(cjd) + qext1d=alog10(cjd_) + + qsca2d=alog10(cjdp1) + qext2d=alog10(cjdp1_) + +* pour k=xku +* # x=xech(j) +* # x=xech(j+1) + + + qsca1u=alog10(cju) + qext1u=alog10(cju_) + + qsca2u=alog10(cjup1) + qext2u=alog10(cjup1_) + + +* Mie exact: +* + +c refrel=(xn,xk) + refrel=cmplx(xn,xk) + call intmie(x,refrel,nang,s1,s2,qext_,qsca_) + do j=1,2*nang-1 + s11(j)=cabs(s2(j))*cabs(s2(j))+cabs(s1(j))*cabs(s1(j)) + enddo + + ENDIF + +* THIS IS MIE: + + qabs_ =qext_ -qsca_ + +* THIS IS FRACTAL 20 MONOMERS +* d + qabs2d=alog10(10.**qext2d-10.**qsca2d) + qabs1d=alog10(10.**qext1d-10.**qsca1d) +* u + qabs2u=alog10(10.**qext2u-10.**qsca2u) + qabs1u=alog10(10.**qext1u-10.**qsca1u) + + +*********************************************************************** +* QUICK FIX FOR NEGATIVE ABSORPTION WHEN APPEARS [OUT OF n RANGE] +********************************************************************** + GOTO 505 +* This avoid a "crash" if one among four of the qsca is larger than qext +* Averaging the w=qsca/qext, and applied to the "wrong" qsca +* NOTE this occurs only if real refractive index > 2 + + w1=10.**qsca2d/10.**qext2d + w2=10.**qsca1d/10.**qext1d + w3=10.**qsca2u/10.**qext2u + w4=10.**qsca1u/10.**qext1u + + + IF(10.**qext2d.lt.10.**qsca2d) + & qsca2d=alog10((10.**qext2d)*(w2+w3+w4)/3.) + IF(10.**qext1d.lt.10.**qsca1d) + & qsca1d=alog10((10.**qext1d)*(w1+w3+w4)/3.) + IF(10.**qext2u.lt.10.**qsca2u) + & qsca2u=alog10((10.**qext2u)*(w2+w1+w4)/3.) + IF(10.**qext1u.lt.10.**qsca1u) + & qsca1u=alog10((10.**qext1u)*(w2+w3+w1)/3.) + + qabs2d=alog10(10.**qext2d-10.**qsca2d) + qabs1d=alog10(10.**qext1d-10.**qsca1d) + qabs2u=alog10(10.**qext2u-10.**qsca2u) + qabs1u=alog10(10.**qext1u-10.**qsca1u) + 505 continue + +************************************************ +* STEP # 5 +************************************************ +* INTERPOLATION OVER THE TWO VARIABLES n*X AND K +************************************************ + +* X*n VARIABLE/ interpolation log-log. + + sextu=((qext2u-qext1u)*xrap+qext1u) + sscau=((qsca2u-qsca1u)*xrap+qsca1u) + sabsu=((qabs2u-qabs1u)*xrap+qabs1u) + sextd=((qext2d-qext1d)*xrap+qext1d) + sscad=((qsca2d-qsca1d)*xrap+qsca1d) + sabsd=((qabs2d-qabs1d)*xrap+qabs1d) + +* K VARIABLE/ interpolation log-log + xki=xk + if (xk.lt.1.e-2) xki=1.e-2 + if (xk.gt.1.) xki=1. + rki=-alog10(xki) + rku=-alog10(xku) + rkd=-alog10(xkd) + ssca=(sscau-sscad)*(rki-rkd)+sscad + sext=(sextu-sextd)*(rki-rkd)+sextd + sabs=(sabsu-sabsd)*(rki-rkd)+sabsd + + sscap=(sscau-sscad)*(rki-rkd)+sscad + sextp=(sextu-sextd)*(rki-rkd)+sextd + sabsp=(sabsu-sabsd)*(rki-rkd)+sabsd + +* storage Mie down and up +c refrel=(xn,1.) + refrel=cmplx(xn,1.) + call intmie(x,refrel,nang,s1,s2,qextmd_,qscamd_) + qabsmd_=qextmd_-qscamd_ + +c refrel=(xn,.1) + refrel=cmplx(xn,.1) + call intmie(x,refrel,nang,s1,s2,qextmu_,qscamu_) + qabsmu_=qextmu_-qscamu_ + +****************************************************** +* STEP # 5.1 : +****************************************************** +* SPECIAL CASE FOR LARGE k (>.1) : MAXWELL GARNETT +****************************************************** + + + if (xk.gt.0.1) then ! THIS CONCERNS THE LARGE IMAGINARY REFRACTIVE INDEXES + +*Prepare Maxwell Garnett approx. (see B&H) +*----------------------------------------- + + xbulk=x*(NC*1.)**.3333333 + xsphe=x*(NC*1.)**.5 + frac=(xbulk/xsphe)**3. + xkff=xk*frac + xnff=1.+(xn-1.)*frac + +* For small x, aggregate scattering= N**2 monmer scatt.: +* ----------------------------------------------------- + + mtest=cmplx(xn,xk) + call intmie(x,mtest,nang,s1,s2,qe,qs) + sscaR=alog10(qs*NC*(xsphe/x)**2.) + + +* For small x, aggregate abs. is proportionnal to N +* ----------------------------------------------------- + mtest=cmplx(xn,xk) + call intmie(x,mtest,nang,s1,s2,qe,qs) + sabsR=alog10((qe-qs)*20.) + + + endif + + + +***************************************************************** +* FINALLY, WE GET THE VALUES FOR AN AGGREGATE OF 20 MONOMERS +* FOR THE ACTUAL X,k, AND n +***************************************************************** + + + ssca=10.**ssca + sext=10.**sext + sabs=10.**sabs + +* Sharp cross over between Rayleigh + xup=0.3 ! |<---------- + xdo=0.3 ! --------->| + + if (xk.gt.0.1) then ! large imaginary refractive index + + if (x*xn.ge.xup) then ! large size parameter + sext=sabs+ssca + scal1=(10.**sabsd)/qabsmd_ + scal2=(10.**sabsu)/qabsmu_ + scalx=(alog10(xk)+1.)*(scal1-scal2)+scal2 + sabs=qabs_*scalx + ssca=sext-sabs + endif + + if (x*xn.le.xdo) then ! PURE RAYLEIGH + sabs=10.**sabsR + ssca=10.**sscaR + sext=sabs+ssca + endif + + + else + + sext=sabs+ssca !self-consistent ext sca abs set + + endif + + +***************************************************************** +* STEP # 6 +***************************************************************** +* NOW, USE USE THE N-LAWS TO COMPUTE THE Q(N) FROM Q(N=20) AND +* THE Q(MIE) [EQUATIONS (9) AND (10)]. +***************************************************************** + + g0=0. + g1=0. + g2=0. + + surf=rad**2.*3.1415926*1.e18 + + +* STEP # 6.1 +***************************************************************** +* FIRST; COMPUTE THE STRUCTURE TERM THAT IS ONLY USED TO COMPUTE +* THE ASYMETRY PARAMETER THAT DEPENDS ON THE SHAPE OF THE PHASE +* FUNCTION. +***************************************************************** + + + do 367 j=1,2*nang-1 + z=sin(theta(j)/2.) + xx_=alphaS*x*(NB*1.)**(1./DFS) + call structure(NB,xx_,z,str,DFS) + if (z.eq.0.) str=(NB*1.)**2. + strS(j)=str + 367 continue + + + do 365 j=1,2*nang-2,2 + + g1=2*dang/6*(s11(j)*sin(theta(j))*strS(j) + & +s11(j+2)*sin(theta(j+2))*strS(j+2) + & +4*s11(j+1)*sin(theta(j+1))*strS(j+1)) + & *2*3.141592+g1 + + g2=2*dang/6*(s11(j)*sin(theta(j))*cos(theta(j))*strS(j) + & +s11(j+2)*sin(theta(j+2))*cos(theta(j+2))*strS(j+2) + & +4*s11(j+1)*sin(theta(j+1))*cos(theta(j+1))*strS(j+1)) + & *2.*3.141592+g2 + + 365 continue + + +* STEP # 6.2 +***************************************************************** +* USE THE EQUATIONS (10) AND (9) FOR MEDIUM RANGE OR THE RAYLEIGH +* RANGE. +***************************************************************** + + +* 1: FOR MEDIUM X RANGE: 1< X < 10 to 50 [EQ 10] +* 2: FOR VERY LARGE X RANGE: X >> 50 [EQ 11] +* N^a LOG(N^b) IS REPLACED BY A PURE N^a LAW. THIS OCCURS +* WHEN N>50 FOR ABSORPTION AND WHEN N>25/x FOR SCATTERING, +* AND CORRESPOND TO THE GEOMETRIC RANGE. THE EXPONENT a IS +* SET BY EMPIRIC CONSIDERATIONS (SEE PAPER). + +* XEXP5 AND XEXP6 ARE THE EXPONENT FACTOR USED IN EQ 10 +* XEXP1 AND XEXP2 ARE THE EXPONENT FACTOR USED VERY LARGE BEHAVIOUR + + xkf=1. + if (xk.le.1.e-2) xkf=xk/1.e-2 + + + rho=(NC*1.)**xexp5 + rho_=(NB*1.)**xexp5 + +* EQ 10 RESULT FOR ABSORPTION: +*----------------------------- + + sabs1=(sabs*xkf-qabs_)/alog10(20.)*alog10(NB*1.) + & *rho_/rho+qabs_ + + +* NB: IF NB>NTA OR NB>NTS , EFFICIENCY FACTOR FOLLOW A POWER LAW +* BEHAVIOUR. ELSE, EQUATION 10 IS VALIDE. + + NTA=50 + + if(NB.gt.NTA) then + rhox=(NTA*1.)**xexp5 + +* COMPUTE sabs1 FOR NTA TO START THE POWER LAW: + sabs1=(sabs*xkf-qabs_)/alog10(20.)*alog10(NTA*1.) + & *rhox/rho+qabs_ + +* COMPUTE xexp1 EXPONENT FACTOR: + xexp1=.85 + if(x*xn.lt.2.2) xexp1=(.85-.96)*1.42*(x*xn-1.5)+.96 + if(x*xn.lt.1.5) xexp1=.96 + +* COMPUTE sabs1 VALUE FOR LARGE X: + sabs1=sabs1*(NB*1./(NTA*1.))**xexp1 + endif + +* HERE SABS1 MEDIUM RANGE IS KNOWN + + rho=(NC*1.)**xexp6 + rho_=(NB*1.)**xexp6 + + +* EQ 10 RESULT FOR SCATTERING: +*----------------------------- + + ssca1=(ssca-qsca_)/alog10(20.)*alog10(NB*1.) + & *rho_/rho+qsca_ + + NTS=int((20./x)**(1./.65)) + +* NB: IF NB>NTA OR NB>NTS , EFFICIENCY FACTOR FOLLOW A POWER LAW +* BEHAVIOUR. ELSE, EQUATION 10 IS VALIDE. + + if(NB.gt.NTS) then + rhox=(NTS*1.)**xexp6 + +* COMPUTE sabs1 FOR NTS TO START THE POWER LAW: + ssca1=(ssca-qsca_)/alog10(20.)*alog10(NTS*1.) + & *rhox/rho+qsca_ + +* COMPUTE xexp2 EXPONENT FACTOR: + xexp2=.95 + if(x.lt.1.0) xexp2=(.95-1.1)*2*(x-.5)+1.1 + +* COMPUTE sabs1 VALUE FOR LARGE X: + ssca1=ssca1*(NB*1./(NTS*1.))**xexp2 + endif + +* HERE SSCA1 MEDIUM RANGE IS KNOWN + + + sext1=ssca1+sabs1 + + + + + +* 3: FOR THE RAYLEIGH RANGE [EQ 9] + + ssca2=(alog10(ssca)-alog10(qsca_))/alog10(20.) + & *alog10(NB*1.)+alog10(qsca_) + sext2=(alog10(sext)-alog10(qext_))/alog10(20.) + & *alog10(NB*1.)+alog10(qext_) + sabs2=(alog10(sabs*xkf)-alog10(qabs_))/alog10(20.) + & *alog10(NB*1.)+alog10(qabs_) + + + +************************************************ +* STEP # 7 +************************************************ +* THE CROSS OVER BETWEEN RAYLEYGH AND MEDIUM RANGE +************************************************ + + rho_=(NB*1.)**.66666 +* 1< X < 50. + sext1=alog10(sext1/rho_) + ssca1=alog10(ssca1/rho_) + sabs1=alog10(sabs1/rho_) +* RAYLEIGH + sext2=alog10((10.**sext2)/rho_) + ssca2=alog10((10.**ssca2)/rho_) + sabs2=alog10((10.**sabs2)/rho_) + + + + + + +* 7.1: SCATTERING AND EXTINCTION + CROSS OVER +************************************************ + + +* RAYLEIGH RANGE: + fsca=10.**(ssca2) + fext=10.**(sext2) + fg=g2/g1 + + xx=.5*alpha*x*(NB*1.)**.33333 + xup=10. + xdo=.1 + + f=alog10(xx/xdo)/alog10(xup/xdo) + g=1.-f + + +* MEDIUM X + if (xx.le.xup.and.xx.ge.xdo) then + fsca=10.**(f*ssca1+g*ssca2) + fext=10.**(f*sext1+g*sext2) + fg=g2/g1 + endif + +* LARGE X + if (xx.gt.xup) then + fsca=10.**(ssca1) + fext=10.**(sext1) + fg=g2/g1 + endif + +* 7.2: ABSORPTION + CROSS OVER +************************************************ + +* RAYLEIGH RANGE + + fabs=10.**(sabs2) + + xx=.5*alpha*x*(NB*1.)**.5 + f=alog10(xx/xdo)/alog10(xup/xdo) + g=1.-f + +* MEDIUM X + if (xx.le.xup.and.xx.ge.xdo) then + fabs=10.**(f*sabs1+g*sabs2) + endif + +* LARGE X + if (xx.gt.xup) then + fabs=10.**(sabs1) + endif + + fext=fsca+fabs + + +*********************************************** +* STEP # 8 +*********************************************** +* DISPLAY THE RESULTS : PHASE FUNCTION OR +* EFFICIENCY COEFFICIENTS +*********************************************** + + IF (IND.eq.1) THEN + +* 8.1: CROSS SECTIONS & PHASE FUNCTION +*********************************************** + + tot =0. + scoef=NB**(2./3.)*rad**2.*3.1415926 + + do 366 j=1,2*nang-1 + + pp(1,j)=theta(j)*180./3.1415926 + pp(2,j)=s11(j)*2*3.1415936*strS(j)*1./g1 + 366 continue +* + ELSE + +* 8.2: EFFICIENCY COEFFICIENTS +*********************************************** + + scoef=NB**(2./3.)*rad**2.*3.1415926 ! METERS^2 + fsca=fsca*scoef + fext=fext*scoef + fabs=fabs*scoef + +c new fashion... + + fabs=(qext_-qsca_)*NB/(NB*1.)**(2./3.)*scoef + fext=fsca+fabs + + + ENDIF + + return + end + +c------------------------------------------------------------ + subroutine intmie(x,refrel,nang,s1,s2, + & qext,qsca) +********************************************************** +* THIS ROUTINE COMES FROM BORHEN AND HUFFMAN BOOK: +* "ABSORPTION AND SCATTERING OF LIGHT BY SMALL PARTICLES" +* WILEY INTERSCIENCE PUBLICATION, 1983 +********************************************************** + common/angle11/theta + + real amu(10000),theta(10000),pi(10000) + real tau(10000),pi0(10000),pi1(10000) + complex d(300000),y,refrel,xi,xi0,xi1,an,bn,s1(20000),s2(20000) + complex s_(20000) + double precision psi0,psi1,psi,dn,dx + dx=x !dx en double precision .... + y=x*refrel + + xstop=x+4*x**.3333+2. + nstop=xstop + ymod=cabs(y) + nmx=amax1(xstop,ymod)+15 +c print*,nmx,xstop,nstop,ymod + dang=1.570796327/dfloat(nang-1) + do 555 j=1,2*nang-1 + theta(j)=(dfloat(j)-1.)*dang + 555 amu(j)=cos(theta(j)) +c d(nmx)=(0.,0.) + d(nmx)=cmplx(0.,0.) + nn=nmx-1 + + do 120 n=1,nn + rn=nmx-n+1 + d(nmx-n)=(rn/y)-(1./(d(nmx-n+1)+rn/y)) + 120 continue + + do 666 j=1,nang + pi0(j)=0. ! fonction de legendre + 666 pi1(j)=1. + + nn=2*nang-1 + + do 777 j=1,nn +c s_(j)=(0.,0.) +c s1(j)=(0.,0.) +c777 s2(j)=(0.,0.) + s_(j)=cmplx(0.,0.) + s1(j)=cmplx(0.,0.) + 777 s2(j)=cmplx(0.,0.) + psi0=dcos(dx) !initialisation des fonctions de Bessel + psi1=dsin(dx) + chi0=-sin(x) + chi1=cos(x) + apsi0=psi0 !psi en double prec. et apsi en simple + apsi1=psi1 +c xi0=(apsi0,-chi0) +c xi1=(apsi1,-chi1) + xi0=cmplx(apsi0,-chi0) + xi1=cmplx(apsi1,-chi1) + qsca=0. + qsca_=0. + n=1 +c *************debut de l'iteration sur n ************* + 200 dn=n + rn=n + fn=(2.*rn+1.)/(rn*(rn+1.)) + + psi=(2.*dn-1.)*psi1/dx-psi0 ! calcul des fct de Bessel + chi=(2.*rn-1.)*chi1/x-chi0 ! relation recurrente a 2 niveaux + apsi=psi +c xi=(apsi,-chi) + xi=cmplx(apsi,-chi) + an=(d(n)/refrel+rn/x)*apsi-apsi1 + an=an/((d(n)/refrel+rn/x)*xi-xi1) + bn=(refrel*d(n)+rn/x)*apsi-apsi1 + bn=bn/((refrel*d(n)+rn/x)*xi-xi1) + qsca=qsca+(2*rn+1.)*(cabs(an)*cabs(an)+cabs(bn)*cabs(bn)) + +c ***************debut de la boucle sur les angles******* + do 789 j=1,nang + jj=2*nang-j + pi(j)=pi1(j) ! + tau(j)=rn*amu(j)*pi(j)-(rn+1.)*pi0(j) ! fonction de legendre + s1(j)=s1(j)+fn*(an*pi(j)+bn*tau(j)) + s2(j)=s2(j)+fn*(an*tau(j)+bn*pi(j)) + p=(-1)**(n-1) + t=(-1)**n + if (j.eq.jj) goto 789 + s1(jj)=s1(jj)+fn*(an*pi(j)*p+bn*tau(j)*t) + s2(jj)=s2(jj)+fn*(an*tau(j)*t+bn*pi(j)*p) + 789 continue + psi0=psi1 + psi1=psi + apsi1=psi1 ! double prec=simple + chi0=chi1 + chi1=chi +c xi1=(apsi1,-chi1) + xi1=cmplx(apsi1,-chi1) + n=n+1 + rn=n + do 999 j=1,nang + pi1(j)=((2.*rn-1.)/(rn-1.))*amu(j)*pi(j) + pi1(j)=pi1(j)-rn*pi0(j)/(rn-1.) + 999 pi0(j)=pi(j) + if (n-1-nstop) 200,300,300 + 300 qsca=(2./(x*x))*qsca + qext=(4./(x*x))*real(s1(1)) + qabs=qext-qsca + + + return + end + + + subroutine corrint11(x,xn,xk,NB) + parameter (nech=28) + parameter (nex=6) + real xech(nech) + real A0(2*nech), B0(2*nech), C0(2*nech), D0(2*nech) + real A1(2*nech), B1(2*nech), C1(2*nech), D1(2*nech) + real A2(2*nech), B2(2*nech), C2(2*nech), D2(2*nech) + real A3(2*nech), B3(2*nech), C3(2*nech), D3(2*nech) + real x,xn,xk,correct,correct_ + integer NB,ifirst + real ww1(nex),ww2(nex) + real xx1(nex),xx2(nex) + real yy1(nex),yy2(nex) + real zz1(nex),zz2(nex) + real xldo(nex) + real xexp5,xexp6 + common/pack1/cjup1_,cju_,cjup1,cju,xrapl,xechj,xechjp1 + common/pack2/cjdp1_,cjd_,cjdp1,cjd,xku,xkd,jindex + common/pack3/xexp5,xexp6 +* * ATTENTION: ORDRE INVERSE DANS cfffpf, cfffcs,... * + DATA xech/0.05,0.1,0.25,0.5,0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3, + & 1.4,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75,4.0,4.25, + & 4.5,4.75,5.0/ + DATA A0/ .1117E+00, .2284E+00, .4473E+00,-.3351E+00,-.7323E+00, + & -.8070E+00,-.5968E+00,-.2956E+00, .1171E-01, .2515E+00, + & .3607E+00, .3653E+00, .2658E+00, .1145E+00,-.1505E+00, + & .1982E-01, .8496E-01,-.5869E-01,-.7623E-01,-.5410E-02, + & -.2850E-01,-.5501E-01,-.5267E-01,-.2317E-01,-.3344E-01, + & -.3936E-01,-.3094E-01,-.3099E-01, + & .6136E-03, .7863E-02, .9823E-01, .6704E-01,-.8727E-01, + & -.1741E+00,-.1402E+00,-.3270E-01, .1074E+00, .2397E+00, + & .3254E+00, .3654E+00, .3495E+00, .2869E+00, .7161E-01, + & .6914E-01, .1319E+00, .7578E-01, .2340E-01, .4031E-01, + & .4202E-01, .2560E-01, .1679E-01, .2965E-01, .3108E-01, + & .2983E-01, .3023E-01, .2988E-01/ + DATA B0/-.5034E+00,-.1033E+01,-.2186E+01, .3670E+00, .2014E+01, + & .2646E+01, .2279E+01, .1496E+01, .5713E+00,-.2137E+00, + & -.6203E+00,-.7014E+00,-.4274E+00, .3641E-01, .8890E+00, + & .3026E+00, .4121E-01, .4774E+00, .5016E+00, .2491E+00, + & .3097E+00, .3754E+00, .3536E+00, .2500E+00, .2734E+00, + & .2838E+00, .2453E+00, .2429E+00, + & -.2493E-02,-.3224E-01,-.4251E+00,-.5115E+00, .7309E-01, + & .5198E+00, .5940E+00, .3982E+00, .3812E-01,-.3514E+00, + & -.6344E+00,-.7949E+00,-.7802E+00,-.6081E+00, .5837E-01, + & .4640E-01,-.1963E+00,-.4932E-01, .9157E-01, .1454E-01, + & -.6767E-02, .3216E-01, .4963E-01,-.9453E-04,-.1184E-01, + & -.1405E-01,-.2189E-01,-.2395E-01/ + DATA C0/ .6106E+00, .1257E+01, .2904E+01, .1547E+01, .1531E+00, + & -.5216E+00,-.4001E+00, .1061E+00, .7939E+00, .1421E+01, + & .1776E+01, .1883E+01, .1693E+01, .1334E+01, .6370E+00, + & .1107E+01, .1329E+01, .9812E+00, .9691E+00, .1171E+01, + & .1119E+01, .1070E+01, .1086E+01, .1164E+01, .1145E+01, + & .1135E+01, .1167E+01, .1164E+01, + & .2614E-02, .3429E-01, .4919E+00, .1051E+01, .6861E+00, + & .3474E+00, .2567E+00, .3720E+00, .6355E+00, .9464E+00, + & .1195E+01, .1361E+01, .1388E+01, .1283E+01, .7888E+00, + & .8176E+00, .1038E+01, .9433E+00, .8490E+00, .9234E+00, + & .9487E+00, .9256E+00, .9171E+00, .9601E+00, .9731E+00, + & .9774E+00, .9868E+00, .9892E+00/ + DATA A1/ .8917E-02, .1683E-01, .1060E-01,-.2180E+00,-.4334E+00, + & -.6977E+00,-.9510E+00,-.1114E+01,-.1154E+01,-.1186E+01, + & -.1170E+01,-.1184E+01,-.1214E+01,-.1243E+01,-.1324E+01, + & -.1570E+01,-.1304E+01,-.7215E+00,-.9031E+00,-.1164E+01, + & -.5731E+00,-.4235E+00,-.8438E+00,-.3892E+00, .3259E+00, + & .2680E+00, .6864E+00, .1542E+01, + & -.6903E-04,-.1081E-02,-.2849E-01,-.2557E+00,-.4515E+00, + & -.6935E+00,-.9313E+00,-.1098E+01,-.1165E+01,-.1222E+01, + & -.1239E+01,-.1285E+01,-.1353E+01,-.1432E+01,-.1606E+01, + & -.1809E+01,-.1613E+01,-.1139E+01,-.1174E+01,-.1452E+01, + & -.1075E+01,-.7739E+00,-.1122E+01,-.8658E+00, .8014E-02, + & .2460E+00, .7393E+00, .1802E+01/ + DATA B1/-.4265E-01,-.8221E-01,-.9239E-01, .7328E+00, .1571E+01, + & .2661E+01, .3805E+01, .4705E+01, .5192E+01, .5586E+01, + & .5713E+01, .5844E+01, .5940E+01, .5939E+01, .5617E+01, + & .6022E+01, .5165E+01, .2970E+01, .3196E+01, .4005E+01, + & .1932E+01, .1164E+01, .2469E+01, .8862E+00,-.1572E+01, + & -.1359E+01,-.2718E+01,-.5456E+01, + & .2345E-03, .3756E-02, .1058E+00, .9941E+00, .1787E+01, + & .2813E+01, .3909E+01, .4823E+01, .5400E+01, .5881E+01, + & .6131E+01, .6373E+01, .6598E+01, .6769E+01, .6816E+01, + & .7097E+01, .6380E+01, .4542E+01, .4294E+01, .5046E+01, + & .3642E+01, .2361E+01, .3303E+01, .2337E+01,-.6819E+00, + & -.1528E+01,-.3110E+01,-.6542E+01/ + DATA C1/ .5537E-01, .1094E+00, .1933E+00,-.3295E+00,-.9664E+00, + & -.1836E+01,-.2791E+01,-.3579E+01,-.4033E+01,-.4384E+01, + & -.4467E+01,-.4506E+01,-.4480E+01,-.4338E+01,-.3594E+01, + & -.3592E+01,-.2857E+01,-.9067E+00,-.8569E+00,-.1483E+01, + & .2426E+00, .1010E+01,-.2250E-01, .1272E+01, .3286E+01, + & .3064E+01, .4112E+01, .6241E+01, + & -.1499E-03,-.2538E-02,-.7950E-01,-.7859E+00,-.1437E+01, + & -.2302E+01,-.3255E+01,-.4084E+01,-.4636E+01,-.5081E+01, + & -.5287E+01,-.5434E+01,-.5522E+01,-.5524E+01,-.5105E+01, + & -.5006E+01,-.4323E+01,-.2649E+01,-.2219E+01,-.2726E+01, + & -.1514E+01,-.3276E+00,-.9927E+00,-.1745E+00, .2306E+01, + & .2984E+01, .4190E+01, .6871E+01/ + DATA A2/ .8210E-03, .6438E-03,-.2567E-01,-.2701E+00,-.4978E+00, + & -.8074E+00,-.1155E+01,-.1458E+01,-.1649E+01,-.1731E+01, + & -.1683E+01,-.1675E+01,-.1646E+01,-.1544E+01,-.1234E+01, + & -.1855E+01,-.1307E+01,-.2446E+00,-.5417E+00,-.1624E+01, + & -.2091E+00, .2351E+00,-.1552E+01,-.5738E+00, .1313E+01, + & .4078E-01, .1116E+01, .5153E+01, + & -.7454E-04,-.1152E-02,-.2981E-01,-.2758E+00,-.5027E+00, + & -.8111E+00,-.1158E+01,-.1463E+01,-.1658E+01,-.1747E+01, + & -.1709E+01,-.1708E+01,-.1687E+01,-.1596E+01,-.1308E+01, + & -.1910E+01,-.1371E+01,-.3399E+00,-.6009E+00,-.1651E+01, + & -.3374E+00, .1413E+00,-.1566E+01,-.7407E+00, .1151E+01, + & .9063E-01, .1134E+01, .5181E+01/ + DATA B2/-.4020E-02,-.4571E-02, .9034E-01, .1031E+01, .1929E+01, + & .3185E+01, .4662E+01, .6060E+01, .7090E+01, .7687E+01, + & .7703E+01, .7758E+01, .7644E+01, .7176E+01, .5232E+01, + & .6690E+01, .4972E+01, .1198E+01, .1616E+01, .5180E+01, + & .4740E+00,-.1502E+01, .4302E+01, .9918E+00,-.5496E+01, + & -.1222E+01,-.4838E+01,-.1792E+02, + & .2569E-03, .4046E-02, .1111E+00, .1065E+01, .1964E+01, + & .3219E+01, .4696E+01, .6101E+01, .7148E+01, .7768E+01, + & .7824E+01, .7907E+01, .7820E+01, .7389E+01, .5527E+01, + & .6926E+01, .5219E+01, .1545E+01, .1852E+01, .5278E+01, + & .8977E+00,-.1184E+01, .4303E+01, .1494E+01,-.5022E+01, + & -.1536E+01,-.4991E+01,-.1814E+02/ + DATA C2/ .5370E-02, .8378E-02,-.5663E-01,-.7911E+00,-.1516E+01, + & -.2549E+01,-.3786E+01,-.4980E+01,-.5871E+01,-.6372E+01, + & -.6307E+01,-.6228E+01,-.5961E+01,-.5361E+01,-.3045E+01, + & -.3777E+01,-.2316E+01, .8933E+00, .8813E+00,-.1974E+01, + & .1810E+01, .3680E+01,-.9658E+00, .1690E+01, .7053E+01, + & .3513E+01, .6392E+01, .1679E+02, + & -.1729E-03,-.2839E-02,-.8489E-01,-.8456E+00,-.1578E+01, + & -.2617E+01,-.3861E+01,-.5067E+01,-.5977E+01,-.6502E+01, + & -.6476E+01,-.6425E+01,-.6184E+01,-.5615E+01,-.3369E+01, + & -.4053E+01,-.2592E+01, .5416E+00, .6159E+00,-.2112E+01, + & .1417E+01, .3365E+01,-.9937E+00, .1261E+01, .6647E+01, + & .3797E+01, .6509E+01, .1696E+02/ + DATA itime /0/ + data xldo/0.1,0.5,1.0,2.0,4.0,8.0/ + data xx1/0.66,0.70,0.60,0.50,0.50,0.59/ + data xx2/0.66,0.70,0.81,0.60,0.59,0.62/ + data yy1/0.66,0.70,0.52,0.44,0.59,0.59/ + data yy2/0.66,0.70,0.74,0.55,0.62,0.62/ + data zz1/0.66,0.70,0.42,0.48,0.55,0.59/ + data zz2/0.66,0.70,0.65,0.55,0.63,0.62/ + + save ifirst + + if (ifirst.eq.0) then + print*,' IFIRST', ifirst + do i=1,nech + xech(i)=xech(i)*1.7 + enddo + ifirst=1 + endif + +** 1: compute the exponent of the law N^a LOG N +** with the index n and the size parameter x +**************************************************** + xexp5=0.66666 + xexp6=0.66666 +****** INTERPOLATION WITH THE VALUE OF REAL REFR. INDEX + do i=1,nex + if(xn.lt.1.7) then + ww1(i)=(yy1(i)-xx1(i))/.3*(xn-1.4)+xx1(i) + ww2(i)=(yy2(i)-xx2(i))/.3*(xn-1.4)+xx2(i) + endif + if(xn.ge.1.7) then + ww1(i)=(zz1(i)-yy1(i))/.3*(xn-1.7)+yy1(i) + ww2(i)=(zz2(i)-yy2(i))/.3*(xn-1.7)+yy2(i) + endif + enddo +****** INTERPOLATION WITH THE SIZE PARAMETER +******** XEXP5 AND XEXP6 ARE THE EXPONENT TO USE IN N^a LOGN LAW + do i=2,nex + if(x.lt.xldo(i).and.x.ge.xldo(i-1)) then + rap=xldo(i)-xldo(i-1) + xexp5=(ww1(i)-ww1(i-1))/rap*(x-xldo(i-1))+ww1(i-1) + xexp6=(ww2(i)-ww2(i-1))/rap*(x-xldo(i-1))+ww2(i-1) + endif + enddo + if(x.ge.xldo(nex)) then + xexp5=ww1(nex) + xexp6=ww2(nex) + endif + + xxn=xn*x + +** location in the defined range of n +******************************************** +** Out of the range + xni=xn + dxn=0. + if (xn.lt.1.4) then + dxn=(xn-1.4) + xn=1.4 + endif + if (xn.gt.2.0) then + dxn=(xn-2.0) + xn=2.0 + endif + +** location in the defined ranges of n*X +******************************************** +** Out of the range + if (xxn.ge.xech(nech)) xxn=xech(nech)*.99 +** Rayleigh range + if (xxn.lt.xech(1)) xxn=xech(1) + do i=1,nech + if(xech(i).le.xxn) j=i + enddo +** Location inside the slab j to j+1 + xechj=xech(j) + xechjp1=xech(j+1) + jindex=j + xrap=(xxn-xech(j))/(xech(j+1)-xech(j)) + xrapl=(alog10(xxn)-alog10(xech(j))) + & /(alog10(xech(j+1))-alog10(xech(j))) + if(xxn.gt.1.7) xrapl=xrap +*************************************************** +** Calculation of the (parabolic) coefficients ** +*************************************************** + xki=xk + if (xk.lt.1.e-2) xki=1.e-2 + if (xk.gt.1.) xki=1. + rki=-alog10(xki) +**** Computation of the parabolic coefficients +** For index j +* f(x0+dx)=f(x0)+[df/dx](x0)*dx +* with f=ax^2+bx+c ---> f'=[f-c+ax^2]/x=2ax+b +* + if(rki.gt.2.) then + cjd =A2(j) *xn**2.+B2(j) *xn+C2(j) + cjd_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) + cju =A2(j) *xn**2.+B2(j) *xn+C2(j) + cju_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) +* neutre si dxn=0 : + cjd =cjd +(cjd -C2(j) +A2(j) *xn**2.)/xn*dxn + cjd_=cjd_+(cjd_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn + cju =cju +(cju -C2(j) +A2(j) *xn**2.)/xn*dxn + cju_=cju_+(cju_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn + xku=1.e-2 + xkd=1.e-2 + endif + if(rki.le.2.) then + cjd =A1(j) *xn**2.+B1(j) *xn+C1(j) + cjd_=A1(j+nech)*xn**2.+B1(j+nech)*xn+C1(j+nech) + cju =A2(j) *xn**2.+B2(j) *xn+C2(j) + cju_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) +* neutre si dxn=0 : + cjd =cjd +(cjd -C1(j) +A1(j) *xn**2.)/xn*dxn + cjd_=cjd_+(cjd_-C1(j+nech)+A1(j+nech)*xn**2.)/xn*dxn + cju =cju +(cju -C2(j) +A2(j) *xn**2.)/xn*dxn + cju_=cju_+(cju_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn + xku=1.e-2 + xkd=1.e-1 + endif + if(rki.le.1.) then + cju =A1(j) *xn**2.+B1(j) *xn+C1(j) + cju_=A1(j+nech)*xn**2.+B1(j+nech)*xn+C1(j+nech) + cjd =A0(j) *xn**2.+B0(j) *xn+C0(j) + cjd_=A0(j+nech)*xn**2.+B0(j+nech)*xn+C0(j+nech) +* neutre si dxn=0 : + cjd =cjd +(cjd -C0(j) +A0(j) *xn**2.)/xn*dxn + cjd_=cjd_+(cjd_-C0(j+nech)+A0(j+nech)*xn**2.)/xn*dxn + cju =cju +(cju -C1(j) +A1(j) *xn**2.)/xn*dxn + cju_=cju_+(cju_-C1(j+nech)+A1(j+nech)*xn**2.)/xn*dxn + xku=1.e-1 + xkd=1.e-0 + endif + + +** For index j+1 + if(rki.gt.2.) then + cjdp1 =A2(j+1) *xn**2.+B2(j+1) *xn+C2(j+1) + cjdp1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) + cjup1 =A2(j+1) *xn**2.+B2(j+1) *xn+C2(j+1) + cjup1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) +* neutre si dxn=0 : + cjdp1 =cjdp1 +(cjdp1 -C2(j+1) +A2(j+1) *xn**2.)/xn*dxn + cjdp1_=cjdp1_+(cjdp1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn + cjup1 =cjup1 +(cjup1 -C2(j+1) +A2(j+1) *xn**2.)/xn*dxn + cjup1_=cjup1_+(cjup1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn + xku=1.e-2 + xkd=1.e-2 + endif + if(rki.le.2.) then + cjdp1 =A1(j+1) *xn**2.+B1(j+1) *xn+C1(j+1) + cjdp1_=A1(j+1+nech)*xn**2.+B1(j+1+nech)*xn+C1(j+1+nech) + cjup1 =A2(j+1) *xn**2.+B2(j+1) *xn+C2(j+1) + cjup1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) +* neutre si dxn=0 : + cjdp1 =cjdp1 +(cjdp1 -C1(j+1) +A1(j+1) *xn**2.)/xn*dxn + cjdp1_=cjdp1_+(cjdp1_-C1(j+1+nech)+A1(j+1+nech)*xn**2.)/xn*dxn + cjup1 =cjup1 +(cjup1 -C2(j+1) +A2(j+1) *xn**2.)/xn*dxn + cjup1_=cjup1_+(cjup1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn + xku=1.e-2 + xkd=1.e-1 + endif + if(rki.le.1.) then + cjup1 =A1(j+1) *xn**2.+B1(j+1) *xn+C1(j+1) + cjup1_=A1(j+1+nech)*xn**2.+B1(j+1+nech)*xn+C1(j+1+nech) + cjdp1 =A0(j+1) *xn**2.+B0(j+1) *xn+C0(j+1) + cjdp1_=A0(j+1+nech)*xn**2.+B0(j+1+nech)*xn+C0(j+1+nech) +* neutre si dxn=0 : + cjdp1 =cjdp1 +(cjdp1 -C0(j+1) +A0(j+1) *xn**2.)/xn*dxn + cjdp1_=cjdp1_+(cjdp1_-C0(j+1+nech)+A0(j+1+nech)*xn**2.)/xn*dxn + cjup1 =cjup1 +(cjup1 -C1(j+1) +A1(j+1) *xn**2.)/xn*dxn + cjup1_=cjup1_+(cjup1_-C1(j+1+nech)+A1(j+1+nech)*xn**2.)/xn*dxn + xku=1.e-1 + xkd=1.e-0 + endif + + +** Computation of the monomer-factor + + cjup1 =cjup1*20. + cjup1_=cjup1_*20. + cju =cju*20. + cju_ =cju_*20. + cjdp1 =cjdp1*20. + cjdp1_=cjdp1_*20. + cjd =cjd*20. + cjd_ =cjd_*20. + xn=xni ! restitution de xn + + return + end + + subroutine structure(NB,X,Z,STRUCT,DF) + implicit real (a-h,o-z) +c integer NB + real NB + real X,Z,D + + D=DF + if (DF.eq.2) D=2.0001 + if (z.eq.0.) z=1.e-4 + + STRUCT=1. + NOSTRUCT=0 ! if asymetry parameters are not needed + ! just skip the computation: save your time! + if (NOSTRUCT.eq.1) goto 102 + u0=5. + pi=3.1415926 +* If convergence test in on (end of the loop): + xacc=1.e-3 +* Else, computation is done once: accuracy is generally about 1% + +* The structure factor is computed in order to evaluate the asymetry +* parameter (not for cross sections). We need to compute the integral +* of the following function: +* +* sin(2XZu)exp(-1/2u**2) for u between 0 and 5. +* +* where X,Z are provided through the subroutine calling +* A=4*pi (normalization factor for D=2 --> Botet et al., 1995) +* +* And STRUCT is given as: +* +* STRUCT=N*[1+(N-1)*2*pi/(A*X*Z) INTEGRAL[sin(2XZu)exp(-1/2u**2)du] +* +* The number of oscillations for sin(2XZu) between 0 and U is: +* n=UXZ/pi.... let integer (simpson integration). + + A=-5.026*D+22.618 + A=A/(2.*pi) !<---- here is A/(2*PI) + nplt=6*int(5.*Z*X/3.1415926+1.) +* nplt=int(5.*Z*X/3.1415926+1.) +* This is the number of periods for the sinus in the range +* u E [0,5]. Integration is done with 6 points per period. +* Accuracy is about 1% on the final result STRUCT. +* +* The minimum value for nplt is set to 17 to do computation +* in the Rayleigh range ( when Z*X reaches 0) + STRUCT=1.e-10 + 101 if ((nplt/2)*1..eq.nplt*.5) nplt=nplt+1 !---> odd + if (nplt.lt.17) nplt=17 + dint=u0/(nplt-1) + STRUCT_OLD=STRUCT + STRUCT=0. + +*** EXTENDED SIMPSON INTEGRATION + iint=0 + ucr=iint*dint + um1=sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.) + STRUCT=STRUCT+um1 + iint=nplt-1 + ucr=iint*dint + um1=sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.) + STRUCT=STRUCT+um1 + + do iint=1,nplt-2,2 + ucr=iint*dint + um1=4.*sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.) + STRUCT=STRUCT+um1 + enddo + + do iint=2,nplt-3,2 + ucr=iint*dint + um1=2.*sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.) + STRUCT=STRUCT+um1 + enddo + STRUCT=dint/3.*STRUCT + ERR=abs(STRUCT_OLD-STRUCT)/STRUCT + nplt=int(nplt*2) +C UNCOMMENT THE IF STATEMENT TO +c SET ON THE CONVERGENCE TEST: +c if (ERR.gt.xacc) GOTO 101 + STRUCT=(STRUCT/(x*z*a)*(NB-1)+1.)*NB + + 102 continue + return + end + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/cirs_haze.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cirs_haze.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cirs_haze.F90 (revision 1643) @@ -0,0 +1,38 @@ +subroutine cirs_haze(press,wno,taeros,taeroscat,cbar) +IMPLICIT NONE + +real,intent(in) :: press,wno +real,intent(inout):: taeros,taeroscat,cbar + +!--------------------------- +! Attention: taeros est en m-1 +! mais la valeur semble devoir etre multipliee par lambda (en m) pour +! obtenir une valeur comparable a celle fournies par Sandrine... +! a tirer au clair... +!--------------------------- + +real :: taerosold +logical,save :: firstcall=.true. + +if (firstcall) then + print*,"CIRS HAZE" + firstcall=.false. +endif + +if (wno.eq.600.) then + print*,press,wno,taeros,taeroscat,cbar +endif + +taerosold = taeros + +! modif de taeros + +! taeroscat est modifie proportionnellement a taeros + +if (taerosold.ne.0.) then + taeroscat = taeroscat/taerosold*taeros +endif + +! Je maintiens le cbar du calcul microphysique + +end subroutine cirs_haze Index: trunk/LMDZ.TITAN.old/libf/phytitan/clcdrag.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/clcdrag.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/clcdrag.F90 (revision 1643) @@ -0,0 +1,99 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/clcdrag.F90,v 1.1.1.1 2004/05/19 12:53:07 lmdzadmin Exp $ +! +! ADAPTATION GCM POUR CP(T) + SUBROUTINE clcdrag(klon, knon, zxli, & + zgeop, zri, & + pcfm, pcfh) + IMPLICIT NONE +! ================================================================= c +! +! Objet : calcul des cdrags pour le moment (pcfm) et +! les flux de chaleur sensible et latente (pcfh). +! +! ================================================================= c +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! zxli----input-L- calcul des cdrags selon Laurent Li +! zgeop---input-R- geopotentiel au 1er niveau du modele +! zri-----input-R- Ridchardson number, premier niveau +! +! pcfm---output-R- cdrag pour le moment +! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible +! + INTEGER, intent(in) :: klon, knon + LOGICAL, intent(in) :: zxli + REAL, intent(in), dimension(klon) :: zgeop + REAL, dimension(klon) :: zri + REAL, intent(out), dimension(klon) :: pcfm, pcfh +! ================================================================= c +! +#include "YOMCST.h" +#include "clesphys.h" +! +! Quelques constantes et options: +! REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0,cepdu2=(0.1)**2 + REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0 +! +! Variables locales : + INTEGER :: i + REAL :: zscf + REAL :: zucf + REAL :: FRIV,FRIH + REAL, dimension(klon) :: zcfm1, zcfm2 + REAL, dimension(klon) :: zcfh1, zcfh2 + REAL, dimension(klon) :: zcdn +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +! ================================================================= c +! +! Calculer le frottement au sol (Cdrag) +! ADAPTATION GCM POUR CP(T) +! + DO i = 1, knon +! +! modif VENUS + zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*z0)))**2 +! +!!$ IF (zri(i) .ge. 0.) THEN ! situation stable + IF (zri(i) .gt. 0.) THEN ! situation stable + zri(i) = min(20.,zri(i)) + IF (.NOT.zxli) THEN + zscf = SQRT(1.+cd*ABS(zri(i))) + FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1) + zcfm1(i) = zcdn(i) * FRIV + FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 ) +!!$ PB zcfh1(i) = zcdn(i) * FRIH + zcfh1(i) = 0.8 * zcdn(i) * FRIH + pcfm(i) = zcfm1(i) + pcfh(i) = zcfh1(i) + ELSE + pcfm(i) = zcdn(i)* fsta(zri(i)) + pcfh(i) = zcdn(i)* fsta(zri(i)) + ENDIF + ELSE ! situation instable + IF (.NOT.zxli) THEN +! +! modif VENUS. zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) & +! modif VENUS. *(1.0+zgeop(i)/(RG*rugos(i))))) + zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) & + *(1.0+zgeop(i)/(RG*z0)))) +! + zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1) +!!$PB zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + zcfh2(i) = 0.8 * zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + pcfm(i) = zcfm2(i) + pcfh(i) = zcfh2(i) + ELSE + pcfm(i) = zcdn(i)* fins(zri(i)) + pcfh(i) = zcdn(i)* fins(zri(i)) + ENDIF + ENDIF + END DO + RETURN + END SUBROUTINE clcdrag + Index: trunk/LMDZ.TITAN.old/libf/phytitan/cld.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cld.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cld.F (revision 1643) @@ -0,0 +1,48 @@ + SUBROUTINE CLD(IPRINT) +C PUT IN A METHANE CLOUD HERE +C THIS ROUTINE SETS UP THE CLOUD DISTRIBUTION +C + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: PI +#include "dimensions.h" + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER) + & , RCLDI(NSPECI), XICLDI(NSPECI), RCLDV(NSPECV), XICLDV(NSPECV) + TOTALC=0.0 +CCC + XC=.95 + DO 190 J=1,NLAYER + XNCLD(J)=0. + RADCLD(J)=0. + IF ( CH4(J)*PRESS(J)/PCH4(TEMP(J)) .GT. XC) THEN + RADCLD(J)=RCLOUD +C TO COLAPSE THE CLOUD INTO ONE LAYER: XC=9. +C LET 1% OF THE GAS BE CLOUD AS AN INTITIAL GUESS + XNCLD(J)=.01*COLDEN(J)*GAS1(J)/((4.*PI/3.)*RADCLD(J)**3*1.E-12) + IF (IPRINT .GT. 0 ) WRITE(6,95) J,RADCLD(J),XNCLD(J),Z(J) + 95 FORMAT(' CLOUD INSERTED: ',I3,F8.2,1P5E10.3) + TOTALC=TOTALC+XNCLD(J) + ENDIF + 190 CONTINUE +C CALL THE MIE CODE TO GIVE THE AEROSOL PROPERTIES AT A REF WAVENO +C WHICH IS THE REF WAVENO OF TOON ET AL. + WNOREF=200. + RREF=1.27 + XIREF=REFLIQ(WNOREF) + CALL XMIE(RCLOUD,RREF,XIREF, + & QEXT,QSCT,QABS,CBAR,WNOREF) + CTAU=QEXT*TOTALC + IF (IPRINT .GT. 0) WRITE(6,98) WNOREF,RREF,XIREF,TOTALC,CTAU + 98 FORMAT(' CLOUD AT REFERENCE WAVENUMBER OF ',F7.2,' REAL, IMG =', + & 1P2E10.2,' COLUMN DENSITY , OPTICAL DEPTH= ',2E10.2) +C SCALE THE CLOUD DENSITIES TO THE REFERENCE WAVENUMBER + DO 145 J=1,NLAYER + XNCLD(J)=XNCLD(J)*TAUFAC/CTAU + 145 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/clesphys.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/clesphys.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/clesphys.h (revision 1643) @@ -0,0 +1,47 @@ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!..include cles_phys.h +! + LOGICAL cycle_diurne,soil_model + LOGICAL ok_orodr,ok_orolf,ok_gw_nonoro + INTEGER nbapp_rad, nbapp_chim, iflag_con, iflag_ajs + REAL ecriphy + INTEGER lev_histmth, lev_histday + REAL solaire + +! Parametres pour PBL: + REAL z0, lmixmin + REAL ksta + LOGICAL ok_kzmin + +! Parametres surface: + REAL inertie,emis + +! Parametres Chimie: + logical chimi,ylellouch,hcnrad + integer vchim,aerprod,htoh2 + +! Parametres Microphysique: + integer microfi,cutoff,clouds + real tx,tcorrect,p_prodaer + real xnuf + REAL xvis,xir + + + COMMON/clesphys_i/ & + & nbapp_rad, nbapp_chim, iflag_con, iflag_ajs, & + & lev_histmth, lev_histday, vchim,aerprod,htoh2, & + & microfi,cutoff,clouds + + COMMON/clesphys_r/ & + & ecriphy, solaire, z0, lmixmin, ksta, inertie, emis, & + & tx,tcorrect,p_prodaer,xnuf,xvis,xir + + COMMON/clesphys_l/cycle_diurne, soil_model, & + & ok_orodr, ok_orolf, ok_gw_nonoro, ok_kzmin, & + & chimi,ylellouch,hcnrad + Index: trunk/LMDZ.TITAN.old/libf/phytitan/clmain.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/clmain.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/clmain.F (revision 1643) @@ -0,0 +1,1238 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/clmain.F,v 1.3 2005/02/07 16:41:35 fairhead Exp $ +! +c +c + SUBROUTINE clmain(dtime,itap, + . t,u,v, + . rmu0, + . ts, + . ftsoil, + . paprs,pplay,ppk,radsol,albe, + . solsw, sollw, sollwdown, fder, + . rlon, rlat, cufi, cvfi, + . debut, lafin, + . d_t,d_u,d_v,d_ts, + . flux_t,flux_u,flux_v,cdragh,cdragm, + . dflux_t, + . zcoefh,zu1,zv1) +cAA REM: +cAA----- +cAA Tout ce qui a trait au traceurs est dans phytrac maintenant +cAA pour l'instant le calcul de la couche limite pour les traceurs +cAA se fait avec cltrac et ne tient pas compte de la differentiation +cAA des sous-fraction de sol. +cAA REM bis : +cAA---------- +cAA Pour pouvoir extraire les coefficient d'echanges et le vent +cAA dans la premiere couche, 3 champs supplementaires ont ete crees +cAA zcoefh,zu1 et zv1. Pour l'instant nous avons moyenne les valeurs +cAA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir +cAA si les informations des subsurfaces doivent etre prises en compte +cAA il faudra sortir ces memes champs en leur ajoutant une dimension, +cAA c'est a dire nbsrf (nbre de subsurface). + USE ioipsl + USE interface_surf + use dimphy + use mod_grid_phy_lmdz, only: nbp_lev + use cpdet_phy_mod, only: t2tpot + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: interface de "couche limite" (diffusion verticale) +c Arguments: +c dtime----input-R- interval du temps (secondes) +c itap-----input-I- numero du pas de temps +c t--------input-R- temperature (K) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c ts-------input-R- temperature du sol (en Kelvin) +c paprs----input-R- pression a intercouche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c radsol---input-R- flux radiatif net (positif vers le sol) en W/m**2 +c rlat-----input-R- latitude en degree +c cufi-----input-R- resolution des mailles en x (m) +c cvfi-----input-R- resolution des mailles en y (m) +c +c d_t------output-R- le changement pour "t" +c d_u------output-R- le changement pour "u" +c d_v------output-R- le changement pour "v" +c d_ts-----output-R- le changement pour "ts" +c flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2) +c (orientation positive vers le bas) +c flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal +c flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal +c dflux_t derive du flux sensible +cAA on rajoute en output yu1 et yv1 qui sont les vents dans +cAA la premiere couche +c====================================================================== +c$$$ PB ajout pour soil +#include "dimsoil.h" +#include "iniprint.h" +#include "clesphys.h" +#include "compbl.h" +c + REAL dtime + integer itap + REAL t(klon,klev) + REAL u(klon,klev), v(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), radsol(klon) +! ADAPTATION GCM POUR CP(T) + real ppk(klon,klev) + REAL rlon(klon), rlat(klon), cufi(klon), cvfi(klon) + REAL d_t(klon, klev) + REAL d_u(klon, klev), d_v(klon, klev) + REAL flux_t(klon,klev) + REAL dflux_t(klon) + + REAL flux_u(klon,klev), flux_v(klon,klev) + REAL cdragh(klon), cdragm(klon) + real rmu0(klon) ! cosinus de l'angle solaire zenithal + LOGICAL debut, lafin +c + REAL ts(klon) + REAL d_ts(klon) + REAL albe(klon) +C + REAL fder(klon) + REAL sollw(klon), solsw(klon), sollwdown(klon) +cAA + REAL zcoefh(klon,klev) + REAL zu1(klon) + REAL zv1(klon) +cAA +c$$$ PB ajout pour soil + REAL ftsoil(klon,nsoilmx) + REAL ytsoil(klon,nsoilmx) +c====================================================================== + EXTERNAL clqh, clvent, coefkz +c====================================================================== + REAL yts(klon) + REAL yalb(klon) + REAL yu1(klon), yv1(klon) + real ysollw(klon), ysolsw(klon), ysollwdown(klon) + real yfder(klon), ytaux(klon), ytauy(klon) + REAL yrads(klon) +C + REAL y_d_ts(klon) + REAL y_d_t(klon, klev) + REAL y_d_u(klon, klev), y_d_v(klon, klev) + REAL y_flux_t(klon,klev) + REAL y_flux_u(klon,klev), y_flux_v(klon,klev) + REAL y_dflux_t(klon) + REAL ycoefh(klon,klev), ycoefm(klon,klev) + REAL yu(klon,klev), yv(klon,klev) + REAL yt(klon,klev) + REAL ypaprs(klon,klev+1), ypplay(klon,klev), ydelp(klon,klev) +c + REAL ycoefm0(klon,klev), ycoefh0(klon,klev) + + real yzlay(klon,klev),yzlev(klon,klev+1) + real yteta(klon,klev) + real ykmm(klon,klev+1),ykmn(klon,klev+1) + real ykmq(klon,klev+1) + real yustar(klon),y_cd_m(klon),y_cd_h(klon) +c +#include "YOMCST.h" + REAL u1lay(klon), v1lay(klon) + REAL delp(klon,klev) + INTEGER i, k + INTEGER ni(klon), knon, j + +c====================================================================== + REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola. +c====================================================================== +c + LOGICAL zxli ! utiliser un jeu de fonctions simples + PARAMETER (zxli=.FALSE.) +c + REAL zt, zdelta, zcor +C + character (len = 20) :: modname = 'clmain' + LOGICAL check + PARAMETER (check=.false.) +C + if (check) THEN + write(*,*) modname,' klon=',klon + call flush(6) + endif + + DO k = 1, klev ! epaisseur de couche + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + DO i = 1, klon ! vent de la premiere couche +ccc zx_alf1 = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2 + v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2 + ENDDO +c +c initialisation: +c + DO i = 1, klon + cdragh(i) = 0.0 + cdragm(i) = 0.0 + dflux_t(i) = 0.0 + zu1(i) = 0.0 + zv1(i) = 0.0 + ENDDO + yts = 0.0 + yalb = 0.0 + yfder = 0.0 + ytaux = 0.0 + ytauy = 0.0 + ysolsw = 0.0 + ysollw = 0.0 + ysollwdown = 0.0 + yu1 = 0.0 + yv1 = 0.0 + yrads = 0.0 + ypaprs = 0.0 + ypplay = 0.0 + ydelp = 0.0 + yu = 0.0 + yv = 0.0 + yt = 0.0 + y_flux_u = 0.0 + y_flux_v = 0.0 +C$$ PB + y_dflux_t = 0.0 + ytsoil = 999999. + DO i = 1, klon + d_ts(i) = 0.0 + ENDDO + flux_t = 0. + flux_u = 0. + flux_v = 0. + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + zcoefh(i,k) = 0.0 + ENDDO + ENDDO +c +c chercher les indices: + DO j = 1, klon + ni(j) = j + ENDDO + knon = klon + + DO j = 1, knon + i = ni(j) + yts(j) = ts(i) + yalb(j) = albe(i) + yfder(j) = fder(i) + ytaux(j) = flux_u(i,1) + ytauy(j) = flux_v(i,1) + ysolsw(j) = solsw(i) + ysollw(j) = sollw(i) + ysollwdown(j) = sollwdown(i) + yu1(j) = u1lay(i) + yv1(j) = v1lay(i) + yrads(j) = ysolsw(j)+ ysollw(j) + ypaprs(j,klev+1) = paprs(i,klev+1) + END DO +C +c$$$ PB ajour pour soil + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ytsoil(j,k) = ftsoil(i,k) + END DO + END DO + DO k = 1, klev + DO j = 1, knon + i = ni(j) + ypaprs(j,k) = paprs(i,k) + ypplay(j,k) = pplay(i,k) + ydelp(j,k) = delp(i,k) + yu(j,k) = u(i,k) + yv(j,k) = v(i,k) + yt(j,k) = t(i,k) + ENDDO + ENDDO +c +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c calculer Cdrag et les coefficients d'echange +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c------------------------------------------------- +c Calcul anciens du LMD. +c dans les routines coefkz, coefkz2, coefkzmin +c------------------------------------------------- + + CALL coefkz(knon, ypaprs, ypplay, ppk, + . yts, yu, yv, yt, + . ycoefm, ycoefh) + +c CALL coefkz2(knon, ypaprs, ypplay,yt, +c . ycoefm0, ycoefh0) +c DO k = 1, klev +c DO i = 1, knon +c ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) +c ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) +c ENDDO +c ENDDO + +c +cIM: 261103 + if (ok_kzmin) THEN +! ADAPTATION GCM POUR CP(T) + print*," coefkzmin: ADAPTATION NON FAITE..." +cIM cf FH: 201103 BEG + +c Calcul d'une diffusion minimale pour les conditions tres stables. +c call coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,ycoefm +c . ,ycoefm0,ycoefh0) +c call dump2d(iim,jjm-1,ycoefm(2:klon-1,2), 'KZ ') +c call dump2d(iim,jjm-1,ycoefm0(2:klon-1,2),'KZMIN ') + + ycoefm0 = 1.e-3 + ycoefh0 = 1.e-3 + + if ( 1.eq.1 ) then + DO k = 1, klev + DO i = 1, knon + ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) + ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) + ENDDO + ENDDO + endif +cIM cf FH: 201103 END + endif !ok_kzmin +cIM: 261103 + + IF (iflag_pbl.ge.3) then +c------------------------------------------------- +c MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin +c------------------------------------------------- + + yzlay(1:knon,1)= + . RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) + . *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG + do k=2,klev + yzlay(1:knon,k)= + . yzlay(1:knon,k-1)+RD*0.5*(yt(1:knon,k-1)+yt(1:knon,k)) + . /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG + enddo + +! ADAPTATION GCM POUR CP(T) + call t2tpot(knon*nbp_lev,yt,yteta,ppk) + + yzlev(1:knon,1)=0. + yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1) + do k=2,klev + yzlev(1:knon,k)=0.5*(yzlay(1:knon,k)+yzlay(1:knon,k-1)) + enddo + + +c Bug introduit volontairement pour converger avec les resultats +c du papier sur les thermiques. + if (1.eq.1) then + y_cd_m(1:knon) = ycoefm(1:knon,1) + y_cd_h(1:knon) = ycoefh(1:knon,1) + else + y_cd_h(1:knon) = ycoefm(1:knon,1) + y_cd_m(1:knon) = ycoefh(1:knon,1) + endif + + call ustarhb(knon,yu,yv,y_cd_m, yustar) + + if (prt_level > 9) THEN + WRITE(lunout,*)'USTAR = ',yustar + ENDIF + +c iflag_pbl peut etre utilise comme longuer de melange + + if (iflag_pbl.ge.11) then + call vdif_kcay(knon,dtime,rg,rd,ypaprs,yt + s ,yzlev,yzlay,yu,yv,yteta + s ,y_cd_m,ykmm,ykmn,yustar, + s iflag_pbl) + else + call yamada4(knon,dtime,rg,rd,ypaprs,yt + s ,yzlev,yzlay,yu,yv,yteta + s ,y_cd_m,ykmm,ykmn,ykmq,yustar, + s iflag_pbl) + endif + + ycoefm(1:knon,1)=y_cd_m(1:knon) + ycoefh(1:knon,1)=y_cd_h(1:knon) + ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev) + ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev) + +c------------------------------------------------- + ENDIF + +c print*,"Kzm=",ycoefm(100,:) +c print*,"Kzh=",ycoefh(100,:) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c calculer la diffusion des vitesses "u" et "v" +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yu,ypaprs,ypplay,ydelp, + s y_d_u,y_flux_u) + CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yv,ypaprs,ypplay,ydelp, + s y_d_v,y_flux_v) + +c pour le couplage + ytaux = y_flux_u(:,1) + ytauy = y_flux_v(:,1) + +c FH modif sur le cdrag temperature +c$$$PB : déplace dans clcdrag +c$$$ do i=1,knon +c$$$ ycoefh(i,1)=ycoefm(i,1)*0.8 +c$$$ enddo + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c calculer la diffusion de "q" et de "h" +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! ADAPTATION GCM POUR CP(T) + CALL clqh(dtime, itap, debut,lafin, + e rlon, rlat, cufi, cvfi, + e knon, + e soil_model, ytsoil, + e rmu0, + e yu1, yv1, ycoefh, + e yt,yts,ypaprs,ypplay,ppk, + e ydelp,yrads,yalb, + e yfder, ytaux, ytauy, + e ysollw, ysollwdown, ysolsw, + s y_d_t, y_d_ts, + s y_flux_t, y_dflux_t) + + DO j = 1, knon + i = ni(j) + d_ts(i) = y_d_ts(j) +c---------------------------------------- +c VENUS TEST: tendance sur Tsurf forcee = 0 +c d_ts(i) = 0. +c---------------------------------------- + albe(i) = yalb(j) + cdragh(i) = cdragh(i) + ycoefh(j,1) + cdragm(i) = cdragm(i) + ycoefm(j,1) + dflux_t(i) = dflux_t(i) + y_dflux_t(j) + zu1(i) = zu1(i) + yu1(j) + zv1(i) = zv1(i) + yv1(j) + END DO + +c$$$ PB ajout pour soil + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ftsoil(i, k) = ytsoil(j,k) + ENDDO + END DO + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + flux_t(i,k) = y_flux_t(j,k) + flux_u(i,k) = y_flux_u(j,k) + flux_v(i,k) = y_flux_v(j,k) + d_t(i,k) = d_t(i,k) + y_d_t(j,k) + d_u(i,k) = d_u(i,k) + y_d_u(j,k) + d_v(i,k) = d_v(i,k) + y_d_v(j,k) + zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k) + ENDDO + ENDDO + +c -------------------- +c TEST!!!!! PAS DE MELANGE PAR TURBULENCE !!! +c d_u = 0. +c d_v = 0. +c flux_u = 0. +c flux_v = 0. +c -------------------- + +c print*,"y_d_t apres clqh=",y_d_t(klon/2,:) + + RETURN + END + +C================================================================= +C================================================================= +C================================================================= +C================================================================= + + SUBROUTINE clqh(dtime,itime, debut,lafin, + e rlon, rlat, cufi, cvfi, + e knon, + $ soil_model,tsoil, + e rmu0, + e u1lay,v1lay,coef, + e t,ts,paprs,pplay,ppk, + e delp,radsol,albedo, + e fder, taux, tauy, + $ sollw, sollwdown, swnet, + s d_t, d_ts, + s flux_t, dflux_s) + + USE interface_surf + use dimphy + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev + use cpdet_phy_mod, only: t2tpot,tpot2t,cpdet + + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: diffusion verticale de "h" +c====================================================================== +#include "YOMCST.h" +#include "dimsoil.h" +#include "iniprint.h" + +c Arguments: + INTEGER knon + REAL dtime ! intervalle du temps (s) + REAL u1lay(klon) ! vitesse u de la 1ere couche (m/s) + REAL v1lay(klon) ! vitesse v de la 1ere couche (m/s) + REAL coef(klon,klev) ! le coefficient d'echange (m**2/s) +c multiplie par le cisaillement du +c vent (dV/dz); la premiere valeur +c indique la valeur de Cdrag (sans unite) + REAL t(klon,klev) ! temperature (K) + REAL ts(klon) ! temperature du sol (K) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) +! ADAPTATION GCM POUR CP(T) + REAL ppk(klon,klev) ! fonction d'Exner milieu de couche + REAL delp(klon,klev) ! epaisseur de couche en pression (Pa) + REAL radsol(klon) ! ray. net au sol (Solaire+IR) W/m2 + REAL albedo(klon) ! albedo de la surface + real rmu0(klon) ! cosinus de l'angle solaire zenithal + real rlon(klon), rlat(klon), cufi(klon), cvfi(klon) +c + REAL d_t(klon,klev) ! incrementation de "t" + REAL d_ts(klon) ! incrementation de "ts" + REAL flux_t(klon,klev) ! (diagnostic) flux de la chaleur +c sensible, flux de Cp*T, positif vers +c le bas: j/(m**2 s) c.a.d.: W/m2 + REAL dflux_s(klon) ! derivee du flux sensible dF/dTs +c====================================================================== + INTEGER i, k + REAL zx_ch(klon,klev) + REAL zx_dh(klon,klev) + REAL zx_buf2(klon) + REAL zx_coef(klon,klev) + REAL local_h(klon,klev) ! enthalpie potentielle + REAL local_ts(klon) +c====================================================================== +c contre-gradient pour la chaleur sensible: Kelvin/metre +! ADAPTATION GCM POUR CP(T) + REAL gamt(klon,klev),zt(klon,klev) + REAL z_gamah(klon,klev) + REAL zdelz +c====================================================================== +#include "compbl.h" +c====================================================================== +c Rajout pour l'interface + integer itime + logical debut, lafin + real zlev1(klon) + real fder(klon), taux(klon), tauy(klon) + real temp_air(klon) + real epot_air(klon) + real tq_cdrag(klon), petAcoef(klon) + real petBcoef(klon) + real sollw(klon), sollwdown(klon), swnet(klon), swdown(klon) + real p1lay(klon),pkh1(klon) +c$$$C PB ajout pour soil + LOGICAL soil_model + REAL tsoil(klon, nsoilmx) + +! Parametres de sortie + real fluxsens(klon) + real tsol_rad(klon), tsurf_new(klon), alb_new(klon) + + character (len = 20) :: modname = 'Debut clqh' + LOGICAL check + PARAMETER (check=.false.) +C + if (iflag_pbl.eq.1) then + do k = 3, klev + do i = 1, knon + gamt(i,k)= -1.0e-03 + enddo + enddo + do i = 1, knon + gamt(i,2) = -2.5e-03 +! ADAPTATION GCM POUR CP(T) + gamt(i,1) = 0.0e0 + enddo + else + do k = 1, klev + do i = 1, knon + gamt(i,k) = 0.0 + enddo + enddo + endif + + DO i = 1, knon + local_ts(i) = ts(i) + ENDDO +! ADAPTATION GCM POUR CP(T) + DO k = 2,klev + DO i = 1, knon + zt(i,k) = (t(i,k)+t(i,k-1)) * 0.5 + ENDDO + ENDDO + +c contre-gradient en potentiel: +! ADAPTATION GCM POUR CP(T) +c en fait, les valeurs mises pour gamt sont pour la T pot... +c Donc on garde les memes... + z_gamah = gamt + +c passage en enthalpie potentielle + call t2tpot(knon*nbp_lev,t,local_h,ppk) +c print*,"tpot en entree de clqh=",local_h(klon/2,:) + + DO k = 1, klev + DO i = 1, knon +c h = tpot*cp + local_h(i,k)= local_h(i,k)*cpdet(t(i,k)) + ENDDO + ENDDO +c print*,"enthalpie potentielle en entree de clqh=", +c . local_h(klon/2,:) +c +c Convertir les coefficients en variables convenables au calcul: +c +c + DO k = 2, klev + DO i = 1, knon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) + . *(paprs(i,k)/zt(i,k)/RD)**2 + zx_coef(i,k) = zx_coef(i,k) * dtime*RG + ENDDO + ENDDO +c +c Preparer les flux lies aux contre-gardients +c + DO k = 2, klev + DO i = 1, knon + zdelz = RD * t(i,k) / RG /paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) +! ADAPTATION GCM POUR CP(T) + z_gamah(i,k) = z_gamah(i,k)*cpdet(zt(i,k))*zdelz + ENDDO + ENDDO +c print*,"contregradient d(enth pot) en entree de clqh=", +c . z_gamah(klon/2,:) + + DO i = 1, knon +! ADAPTATION GCM POUR CP(T) + zx_buf2(i) = delp(i,klev) + zx_coef(i,klev) + zx_ch(i,klev) = (local_h(i,klev)*delp(i,klev) + . -zx_coef(i,klev)*z_gamah(i,klev))/zx_buf2(i) + zx_dh(i,klev) = zx_coef(i,klev) / zx_buf2(i) + ENDDO + DO k = klev-1, 2 , -1 + DO i = 1, knon +! ADAPTATION GCM POUR CP(T) + zx_buf2(i) = delp(i,k)+zx_coef(i,k) + . +zx_coef(i,k+1)*(1.-zx_dh(i,k+1)) + zx_ch(i,k) = (local_h(i,k)*delp(i,k) + . +zx_coef(i,k+1)*zx_ch(i,k+1) + . +zx_coef(i,k+1)*z_gamah(i,k+1) + . -zx_coef(i,k)*z_gamah(i,k))/zx_buf2(i) + zx_dh(i,k) = zx_coef(i,k) / zx_buf2(i) + ENDDO + ENDDO +C +C nouvelle formulation JL Dufresne +C +C h1 = zx_ch(i,1) + zx_dh(i,1) * Flux_H(i,1) * dt +C + DO i = 1, knon +! ADAPTATION GCM POUR CP(T) + zx_buf2(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2)) + zx_ch(i,1) = (local_h(i,1)*delp(i,1) + . +zx_coef(i,2)*(z_gamah(i,2)+zx_ch(i,2))) + . /zx_buf2(i) + zx_dh(i,1) = -1. * RG / zx_buf2(i) + ENDDO + +C Appel a interfsurf (appel generique) routine d'interface avec la surface + +c initialisation + petAcoef =0. + petBcoef =0. + p1lay =0. + +c do i = 1, knon + petAcoef(1:knon) = zx_ch(1:knon,1) + petBcoef(1:knon) = zx_dh(1:knon,1) + tq_cdrag(1:knon) =coef(1:knon,1) + temp_air(1:knon) =t(1:knon,1) + epot_air(1:knon) =local_h(1:knon,1) + pkh1(1:knon) = ppk(1:knon,1) + . *(paprs(1:knon,1)/pplay(1:knon,1))**RKAPPA + p1lay(1:knon) = pplay(1:knon,1) + zlev1(1:knon) = delp(1:knon,1) + swdown(1:knon) = swnet(1:knon) +c enddo + +! ADAPTATION GCM POUR CP(T) + CALL interfsurf_hq(itime, dtime, rmu0, + e klon, nbp_lon, nbp_lat-1, knon, + e rlon, rlat, cufi, cvfi, + e debut, lafin, soil_model, nsoilmx,tsoil, + e zlev1, u1lay, v1lay, temp_air, epot_air, + e tq_cdrag, petAcoef, petBcoef, + e sollw, sollwdown, swnet, swdown, + e fder, taux, tauy, + e albedo, + e ts, pkh1, p1lay, radsol, + s fluxsens, dflux_s, + s tsol_rad, tsurf_new, alb_new) + + + do i = 1, knon + flux_t(i,1) = fluxsens(i) + d_ts(i) = tsurf_new(i) - ts(i) + albedo(i) = alb_new(i) + enddo + +c==== une fois on a zx_h_ts, on peut faire l'iteration ======== + DO i = 1, knon + local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*flux_t(i,1)*dtime + ENDDO + DO k = 2, klev + DO i = 1, knon + local_h(i,k) = zx_ch(i,k) + zx_dh(i,k)*local_h(i,k-1) + ENDDO + ENDDO +c====================================================================== +c== flux_t est le flux de cpt (energie sensible): j/(m**2 s) (+ vers bas) +! ADAPTATION GCM POUR CP(T) + DO k = 2, klev + DO i = 1, knon + flux_t(i,k) = (zx_coef(i,k)/RG/dtime) + . * (local_h(i,k)-local_h(i,k-1)+z_gamah(i,k)) + ENDDO + ENDDO +c====================================================================== +C Calcul tendances +! ADAPTATION GCM POUR CP(T) +c print*,"enthalpie potentielle en sortie de clqh=", +c . local_h(klon/2,:) +c tpot = h/cp + DO k = 1, klev + DO i = 1, knon + local_h(i,k) = local_h(i,k)/cpdet(t(i,k)) + ENDDO + ENDDO + call tpot2t(knon*nbp_lev,local_h,d_t,ppk) + +c print*,"tpot en sortie de clqh=",local_h(klon/2,:) +c print*,"T en sortie de clqh=",d_t(klon/2,:) + DO k = 1, klev + DO i = 1, knon + d_t(i,k) = d_t(i,k) - t(i,k) + ENDDO + ENDDO +c + + RETURN + END + +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== + + SUBROUTINE clvent(knon,dtime, u1lay,v1lay,coef,t,ven, + e paprs,pplay,delp, + s d_ven,flux_v) + + use dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: diffusion vertical de la vitesse "ven" +c====================================================================== +c Arguments: +c dtime----input-R- intervalle du temps (en second) +c u1lay----input-R- vent u de la premiere couche (m/s) +c v1lay----input-R- vent v de la premiere couche (m/s) +c coef-----input-R- le coefficient d'echange (m**2/s) multiplie par +c le cisaillement du vent (dV/dz); la premiere +c valeur indique la valeur de Cdrag (sans unite) +c t--------input-R- temperature (K) +c ven------input-R- vitesse horizontale (m/s) +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c delp-----input-R- epaisseur de couche (Pa) +c +c +c d_ven----output-R- le changement de "ven" +c flux_v---output-R- (diagnostic) flux du vent: (kg m/s)/(m**2 s) +c====================================================================== +#include "iniprint.h" + INTEGER knon + REAL dtime + REAL u1lay(klon), v1lay(klon) + REAL coef(klon,klev) + REAL t(klon,klev), ven(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev) + REAL d_ven(klon,klev) + REAL flux_v(klon,klev) +c====================================================================== +#include "YOMCST.h" +c====================================================================== + INTEGER i, k + REAL zx_cv(klon,2:klev) + REAL zx_dv(klon,2:klev) + REAL zx_buf(klon) + REAL zx_coef(klon,klev) + REAL local_ven(klon,klev) + REAL zx_alf1(klon), zx_alf2(klon) +c====================================================================== + DO k = 1, klev + DO i = 1, knon + local_ven(i,k) = ven(i,k) + ENDDO + ENDDO +c====================================================================== + DO i = 1, knon +ccc zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf1(i) = 1.0 + zx_alf2(i) = 1.0 - zx_alf1(i) + zx_coef(i,1) = coef(i,1) + . * SQRT(u1lay(i)**2+v1lay(i)**2) + . * pplay(i,1)/(RD*t(i,1)) + zx_coef(i,1) = zx_coef(i,1) * dtime*RG + ENDDO +c====================================================================== + DO k = 2, klev + DO i = 1, knon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) + . *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k) * dtime*RG + ENDDO + ENDDO +c====================================================================== + DO i = 1, knon + zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i)+zx_coef(i,2) + zx_cv(i,2) = local_ven(i,1)*delp(i,1) / zx_buf(i) + zx_dv(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) + . /zx_buf(i) + ENDDO + DO k = 3, klev + DO i = 1, knon + zx_buf(i) = delp(i,k-1) + zx_coef(i,k) + . + zx_coef(i,k-1)*(1.-zx_dv(i,k-1)) + zx_cv(i,k) = (local_ven(i,k-1)*delp(i,k-1) + . +zx_coef(i,k-1)*zx_cv(i,k-1) )/zx_buf(i) + zx_dv(i,k) = zx_coef(i,k)/zx_buf(i) + ENDDO + ENDDO + DO i = 1, knon + local_ven(i,klev) = ( local_ven(i,klev)*delp(i,klev) + . +zx_coef(i,klev)*zx_cv(i,klev) ) + . / ( delp(i,klev) + zx_coef(i,klev) + . -zx_coef(i,klev)*zx_dv(i,klev) ) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, knon + local_ven(i,k) = zx_cv(i,k+1) + zx_dv(i,k+1)*local_ven(i,k+1) + ENDDO + ENDDO +c====================================================================== +c== flux_v est le flux de moment angulaire (positif vers bas) +c== dont l'unite est: (kg m/s)/(m**2 s) + DO i = 1, knon + flux_v(i,1) = zx_coef(i,1)/(RG*dtime) + . *(local_ven(i,1)*zx_alf1(i) + . +local_ven(i,2)*zx_alf2(i)) + ENDDO + DO k = 2, klev + DO i = 1, knon + flux_v(i,k) = zx_coef(i,k)/(RG*dtime) + . * (local_ven(i,k)-local_ven(i,k-1)) + ENDDO + ENDDO +c + DO k = 1, klev + DO i = 1, knon + d_ven(i,k) = local_ven(i,k) - ven(i,k) + ENDDO + ENDDO +c + RETURN + END + +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== +c====================================================================== + + SUBROUTINE coefkz(knon, paprs, pplay, ppk, + . ts,u,v,t, + . pcfm, pcfh) + + use dimphy + use cpdet_phy_mod, only: cpdet,t2tpot + IMPLICIT none +c====================================================================== +c Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922 +c (une version strictement identique a l'ancien modele) +c Objet: calculer le coefficient du frottement du sol (Cdrag) et les +c coefficients d'echange turbulent dans l'atmosphere. +c Arguments: +c knon-----input-I- nombre de points a traiter +c paprs----input-R- pression a chaque intercouche (en Pa) +c pplay----input-R- pression au milieu de chaque couche (en Pa) +c ts-------input-R- temperature du sol (en Kelvin) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c t--------input-R- temperature (K) +c +c itop-----output-I- numero de couche du sommet de la couche limite +c pcfm-----output-R- coefficients a calculer (vitesse) +c pcfh-----output-R- coefficients a calculer (chaleur et humidite) +c====================================================================== +#include "YOMCST.h" +#include "iniprint.h" +#include "compbl.h" +#include "clesphys.h" +c +c Arguments: +c + INTEGER knon + REAL ts(klon) + REAL paprs(klon,klev+1), pplay(klon,klev) +! ADAPTATION GCM POUR CP(T) + real ppk(klon,klev) + REAL u(klon,klev), v(klon,klev), t(klon,klev) +c + REAL pcfm(klon,klev), pcfh(klon,klev) + INTEGER itop(klon) +c +c Quelques constantes et options: +c + REAL cepdu2, ckap, cb, cc, cd, clam +c TEST VENUS +c PARAMETER (cepdu2 =(0.1)**2) + PARAMETER (cepdu2 =(1.e-5)**2) + + PARAMETER (CKAP=0.4) + PARAMETER (cb=5.0) + PARAMETER (cc=5.0) + PARAMETER (cd=5.0) + PARAMETER (clam=160.0) + REAL ric ! nombre de Richardson critique + PARAMETER(ric=0.4) + REAL prandtl + PARAMETER (prandtl=0.4) + INTEGER isommet ! le sommet de la couche limite + + LOGICAL tvirtu ! calculer Ri d'une maniere plus performante + PARAMETER (tvirtu=.TRUE.) + LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere + PARAMETER (opt_ec=.FALSE.) + +c +c Variables locales: +c + INTEGER i, k + REAL zgeop(klon,klev) +! ADAPTATION GCM POUR CP(T) + REAL zmgeom(klon,klev),zpk(klon,klev) + REAL zt(klon,klev),ztvu(klon,klev),ztvd(klon,klev) + real ztetav(klon,klev),ztetavu(klon,klev),ztetavd(klon,klev) + REAL zri(klon),z1(klon) + REAL pcfm1(klon), pcfh1(klon) +c + REAL zdphi, zdu2, zcdn, zl2 + REAL zscf + REAL zdelta, zcvm5, zcor + REAL z2geomf, zalh2, zalm2, zscfh, zscfm +cIM + LOGICAL check + PARAMETER (check=.false.) +c +c contre-gradient pour la chaleur sensible: Kelvin/metre + REAL gamt(2:klev) + REAL gamh(2:klev) +c + LOGICAL appel1er + SAVE appel1er +c +c Fonctions thermodynamiques et fonctions d'instabilite + REAL fsta, fins, x + LOGICAL zxli ! utiliser un jeu de fonctions simples + PARAMETER (zxli=.FALSE.) +c + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +c + DATA appel1er /.TRUE./ +c + isommet=klev + + IF (appel1er) THEN + if (prt_level > 9) THEN + WRITE(lunout,*)'coefkz, opt_ec:', opt_ec + WRITE(lunout,*)'coefkz, isommet:', isommet + WRITE(lunout,*)'coefkz, tvirtu:', tvirtu + appel1er = .FALSE. + endif + ENDIF +c +c Initialiser les sorties +c + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, knon + itop(i) = 0 + ENDDO +c +c Prescrire la valeur de contre-gradient +c + if (iflag_pbl.eq.1) then + DO k = 3, klev + gamt(k) = -1.0E-03 + ENDDO + gamt(2) = -2.5E-03 + else + DO k = 2, klev + gamt(k) = 0.0 + ENDDO + ENDIF + +c +c Calculer les geopotentiels de chaque couche +c + DO i = 1, knon + zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, knon + zgeop(i,k) = zgeop(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO +c +c Calculer les coefficients turbulents dans l'atmosphere +! ADAPTATION GCM POUR CP(T) +c tout a ete modifie... +c + + DO k = 2,klev + DO i = 1, knon + zt(i,k) = (t(i,k)+t(i,k-1)) * 0.5 + zmgeom(i,k)= zgeop(i,k)-zgeop(i,k-1) + zdphi = zmgeom(i,k)/2. + ztvd(i,k) = (t(i,k) + zdphi/cpdet(zt(i,k))) + ztvu(i,k) = (t(i,k-1) - zdphi/cpdet(zt(i,k))) + zpk(i,k) = ppk(i,k)*(paprs(i,k)/pplay(i,k))**RKAPPA + ENDDO + ENDDO + DO i = 1, knon + itop(i) = isommet + zt(i,1) = ts(i) + ztvu(i,1) = ts(i) + ztvd(i,1) = t(i,1)+zgeop(i,1)/cpdet(zt(i,1)) + zpk(i,1) = ppk(i,1)*(paprs(i,1)/pplay(i,1))**RKAPPA + ENDDO + call t2tpot(klon*klev,zt,ztetav,zpk) + call t2tpot(klon*klev,ztvu,ztetavu,zpk) + call t2tpot(klon*klev,ztvd,ztetavd,zpk) + + DO k = 2, isommet + DO i = 1, knon + zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 + . +(v(i,k)-v(i,k-1))**2) +c contre-gradient en potentiel: +! ADAPTATION GCM POUR CP(T) +c en fait, les valeurs mises pour gamt sont pour la T pot... +c Donc on garde les memes... + gamh(k) = gamt(k) +c +c calculer le nombre de Richardson: +c + IF (tvirtu) THEN + zri(i) =( zmgeom(i,k)*(ztetavd(i,k)-ztetavu(i,k)) + . + zmgeom(i,k)*zmgeom(i,k)/RG*gamh(k)) ! contregradient + . /(zdu2*ztetav(i,k)) +c + ELSE ! calcul de Richardson compatible LMD5 + print*,"calcul de Richardson sans tvirtu..." + print*,"Pas prevu... A revoir" + stop + ENDIF +c +c finalement, les coefficients d'echange sont obtenus: +c + zcdn=SQRT(zdu2) / zmgeom(i,k) * RG +c + IF (opt_ec) THEN + z2geomf=zgeop(i,k-1)+zgeop(i,k) + zalm2=(0.5*ckap/RG*z2geomf + . /(1.+0.5*ckap/rg/clam*z2geomf))**2 + zalh2=(0.5*ckap/rg*z2geomf + . /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2 + IF (zri(i).LT.0.0) THEN ! situation instable + zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 + . / (zmgeom(i,k)/RG)**3 / (zgeop(i,k-1)/RG) + zscf = SQRT(-zri(i)*zscf) + zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf) + zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf) + pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm) + pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh) + ELSE ! situation stable + zscf=SQRT(1.+cd*zri(i)) + pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf) + pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf) + ENDIF + ELSE + zl2=(lmixmin*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) + . /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2 + pcfm(i,k)=sqrt(max(zcdn*zcdn*(ric-zri(i))/ric, ksta)) + pcfm(i,k)= zl2* pcfm(i,k) + pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different + ENDIF + ENDDO + ENDDO +c Richardson au sol: + DO i = 1, knon + zdu2=MAX(cepdu2,u(i,1)**2+v(i,1)**2) + zri(i) = zgeop(i,1)*(ztetavd(i,1)-ztetavu(i,1)) + . /(zdu2*ztetav(i,1)) + ENDDO +c +c Calculer le frottement au sol (Cdrag) +! ADAPTATION GCM POUR CP(T) +c + DO i = 1, knon + z1(i) = zgeop(i,1) + ENDDO +c + CALL clcdrag(klon, knon, zxli, + $ z1, zri, + $ pcfm1, pcfh1) +C + DO i = 1, knon + pcfm(i,1)=pcfm1(i) + pcfh(i,1)=pcfh1(i) + ENDDO +c +c Au-dela du sommet, pas de diffusion turbulente: +c + DO i = 1, knon + IF (itop(i)+1 .LE. klev) THEN + DO k = itop(i)+1, klev + pcfh(i,k) = 0.0 + pcfm(i,k) = 0.0 + ENDDO + ENDIF + ENDDO +c +c VENUS TEST : +c pcfm(:,:)= 0.15 +c pcfh(:,:)= 0.15 +c +c VENUS TEST : frottement de surface beaucoup plus grand +c pcfm(:,1)= pcfm(:,1)*20. +c pcfh(:,1)= pcfh(:,1)*20. + + RETURN + END + +C================================================================= +C================================================================= +C================================================================= +C================================================================= + + SUBROUTINE coefkz2(knon, paprs, pplay,t, + . pcfm, pcfh) + + use dimphy + use mod_grid_phy_lmdz, only: nbp_lev + use cpdet_phy_mod, only: cpdet + IMPLICIT none +c====================================================================== +c J'introduit un peu de diffusion sauf dans les endroits +c ou une forte inversion est presente +c On peut dire qu'il represente la convection peu profonde +c +c Arguments: +c knon-----input-I- nombre de points a traiter +c paprs----input-R- pression a chaque intercouche (en Pa) +c pplay----input-R- pression au milieu de chaque couche (en Pa) +c t--------input-R- temperature (K) +c +c pcfm-----output-R- coefficients a calculer (vitesse) +c pcfh-----output-R- coefficients a calculer (chaleur et humidite) +c====================================================================== +#include "YOMCST.h" +#include "iniprint.h" +c +c Arguments: +c + INTEGER knon + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pcfm(klon,klev), pcfh(klon,klev) +c +c Variables locales: +c + INTEGER i, k, invb(knon) + REAL zl2(knon), zt + REAL zdthmin(knon), zdthdp +c +c Initialiser les sorties +c + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO +c +c Chercher la zone d'inversion forte +c + DO i = 1, knon + invb(i) = klev + zdthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, knon +! ADAPTATION GCM POUR CP(T) + zt = 0.5*(t(i,k)+t(i,k+1)) + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) + . - RD * zt/cpdet(zt)/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. + . zdthdp.LT.zdthmin(i) ) THEN + zdthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO +c + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/cltrac.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cltrac.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cltrac.F (revision 1643) @@ -0,0 +1,128 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/cltrac.F,v 1.1.1.1 2004/05/19 12:53:07 lmdzadmin Exp $ +! + SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp, + s d_tr) + + use dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): O. Boucher (LOA/LMD) date: 19961127 +c inspire de clvent +c Objet: diffusion verticale de traceurs avec flux fixe a la surface +c ou/et flux du type c-drag +c====================================================================== +c Arguments: +c dtime----input-R- intervalle du temps (en second) +c coef-----input-R- le coefficient d'echange (m**2/s) l>1 +c t--------input-R- temperature (K) +c tr-------input-R- la q. de traceurs +c flux-----input-R- le flux de traceurs a la surface +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c delp-----input-R- epaisseur de couche (Pa) +c cdrag----input-R- cdrag pour le flux de surface (non active) +c tr0------input-R- traceurs a la surface ou dans l'ocean (non active) +c d_tr-----output-R- le changement de tr +c flux_tr--output-R- flux de tr +c====================================================================== + REAL dtime + REAL coef(klon,klev) + REAL t(klon,klev), tr(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev) + REAL d_tr(klon,klev) + REAL flux(klon), cdrag(klon), tr0(klon) +c REAL flux_tr(klon,klev) +c====================================================================== +#include "YOMCST.h" +c====================================================================== + INTEGER i, k + REAL zx_ctr(klon,2:klev) + REAL zx_dtr(klon,2:klev) + REAL zx_buf(klon) + REAL zx_coef(klon,klev) + REAL local_tr(klon,klev) + REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon) +c====================================================================== + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO +c + +c====================================================================== + DO i = 1, klon + zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf2(i) = 1.0 - zx_alf1(i) + zx_flux(i) = -flux(i)*dtime*RG +c--pour le moment le flux est prescrit +c--cdrag et zx_coef(1) vaut 0 + cdrag(i) = 0.0 + tr0(i) = 0.0 + zx_coef(i,1) = cdrag(i)*dtime*RG + ENDDO +c====================================================================== + DO k = 2, klev + DO i = 1, klon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) + . *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k)*dtime*RG + ENDDO + ENDDO +c====================================================================== + DO i = 1, klon + zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2) + zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+ + . zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i) + zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / + . zx_buf(i) + ENDDO +c + DO k = 3, klev + DO i = 1, klon + zx_buf(i) = delp(i,k-1) + zx_coef(i,k) + . + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1)) + zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1) + . +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i) + zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i) + ENDDO + ENDDO + DO i = 1, klon + local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) + . +zx_coef(i,klev)*zx_ctr(i,klev) ) + . / ( delp(i,klev) + zx_coef(i,klev) + . -zx_coef(i,klev)*zx_dtr(i,klev) ) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1) + ENDDO + ENDDO +c====================================================================== +c== flux_tr est le flux de traceur (positif vers bas) +c DO i = 1, klon +c flux_tr(i,1) = zx_coef(i,1)/(RG*dtime) +c ENDDO +c DO k = 2, klev +c DO i = 1, klon +c flux_tr(i,k) = zx_coef(i,k)/(RG*dtime) +c . * (local_tr(i,k)-local_tr(i,k-1)) +c ENDDO +c ENDDO +c====================================================================== + DO k = 1, klev + DO i = 1, klon + d_tr(i,k) = local_tr(i,k) - tr(i,k) + ENDDO + ENDDO +c +c ATTENTION SHUNTE!!!!!! +c DO k = 1, klev +c DO i = 1, klon +c d_tr(i,k) = 0. +c ENDDO +c ENDDO + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/cmie.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cmie.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cmie.F (revision 1643) @@ -0,0 +1,189 @@ + subroutine cmie(lambda,xn,xk,rad,qext,qsca,qabs,gg) + +* COPIE SUR B&H +* lambda: longueur d'onde +* xn, xk: indice de refraction reel et imaginaire +* rad: rayone de la particule +* qsca,qext: coefficient de diffusion et d'absorption +* gg: parametre d'assymetrie + + + common/angle/theta + parameter (nang=451) + complex refrel,s1(20000),s2(20000) + real rad,lambda,s11(20000),theta(10000) + real si1(20000),si2(20000) + +c rad=.525 +c lambda=.6328 + refrel=cmplx(xn,xk) + x=2.*3.14159265*rad/lambda + dang=1.570796327/dfloat(nang-1) + + call intmie2(x,refrel,nang,s1,s2,qext,qsca) + + surf=3.1415926*rad**2.*1e4 + qext=qext*surf + qsca=qsca*surf + qabs=qext-qsca + + + do 355 j=1,2*nang-1 + s11(j)=cabs(s2(j))*cabs(s2(j))+cabs(s1(j))*cabs(s1(j)) + scarre=s11(j) + s11(j)=s11(j)/(2*x**2.) +c print*,scarre,theta(j)*180./3.1415926 + 355 continue + + + tot1=0. + g1=0. + g2=0. + +* s11(j): fonction de phase + + do 365 j=1,2*nang-2,2 + tot1=2*dang/6*(s11(j)*sin(theta(j))+s11(j+2)*sin(theta(j+2)) + & +4*s11(j+1)*sin(theta(j+1)))*2*3.141592+tot1 + + g1=2*dang/6*(s11(j)*sin(theta(j))+s11(j+2)*sin(theta(j+2)) + & +4*s11(j+1)*sin(theta(j+1)))*2*3.141592+g1 + + g2=2*dang/6*(s11(j)*sin(theta(j))*cos(theta(j)) + & +s11(j+2)*sin(theta(j+2))*cos(theta(j+2)) + & +4*s11(j+1)*sin(theta(j+1))*cos(theta(j+1)))*2*3.141592+g2 + + 365 continue + + gg=g2/g1 + do j=1,2*nang-1 +c print*,s11(j)/s11(1),s11(j),qsca +c print*,si1(j),si2(j),theta(j) + + enddo +c print*,'******************************' +c verification que integrale de la fonction de phase= qsca. +c write(*,*) tot,tot1,'int' +c write(*,*) 'asymetrie:',g,s,gg +c print*,'******************************' + return + end + +c------------------------------------------------------------ + subroutine intmie2(x,refrel,nang,s1,s2,qext,qsca) + + common/angle/theta + + real amu(10000),theta(10000),pi(10000) + real tau(10000),pi0(10000),pi1(10000) + complex d(300000),y,refrel,xi,xi0,xi1,an,bn,s1(20000),s2(20000) + double precision psi0,psi1,psi,dn,dx + + dx=x !dx en double precision .... + y=x*refrel + + + xstop=x+4*x**.3333+2. + nstop=xstop + ymod=cabs(y) + nmx=amax1(xstop,ymod)+15 +c print*,nmx,xstop,nstop,ymod + dang=1.570796327/dfloat(nang-1) + + do 555 j=1,2*nang-1 + theta(j)=(dfloat(j)-1.)*dang + 555 amu(j)=cos(theta(j)) + + d(nmx)=cmplx(0.,0.) + nn=nmx-1 + + do 120 n=1,nn + rn=nmx-n+1 + d(nmx-n)=(rn/y)-(1./(d(nmx-n+1)+rn/y)) + 120 continue + + do 666 j=1,nang + pi0(j)=0. ! fonction de legendre + 666 pi1(j)=1. + + nn=2*nang-1 + + do 777 j=1,nn + s1(j)=cmplx(0.,0.) + 777 s2(j)=cmplx(0.,0.) + + + psi0=dcos(dx) !initialisation des fonctions de Bessel + psi1=dsin(dx) + chi0=-sin(x) + chi1=cos(x) + + apsi0=psi0 !psi en double prec. et apsi en simple + apsi1=psi1 + + xi0=cmplx(apsi0,-chi0) + xi1=cmplx(apsi1,-chi1) + + qsca=0. + + n=1 + +c *************debut de l'iteration sur n ************* + 200 dn=n + rn=n + fn=(2.*rn+1.)/(rn*(rn+1.)) + + psi=(2.*dn-1.)*psi1/dx-psi0 ! calcul des fct de Bessel + chi=(2.*rn-1.)*chi1/x-chi0 ! relation recurrente a 2 niveaux + apsi=psi + xi=cmplx(apsi,-chi) + + an=(d(n)/refrel+rn/x)*apsi-apsi1 + an=an/((d(n)/refrel+rn/x)*xi-xi1) + bn=(refrel*d(n)+rn/x)*apsi-apsi1 + bn=bn/((refrel*d(n)+rn/x)*xi-xi1) + + qsca=qsca+(2*rn+1.)*(cabs(an)*cabs(an)+cabs(bn)*cabs(bn)) + +c print*,rn,cabs(an),cabs(bn) +c ***************debut de la boucle sur les angles******* + + do 789 j=1,nang + jj=2*nang-j + pi(j)=pi1(j) ! + tau(j)=rn*amu(j)*pi(j)-(rn+1.)*pi0(j) ! fonction de legendre + s1(j)=s1(j)+fn*(an*pi(j)+bn*tau(j)) + s2(j)=s2(j)+fn*(an*tau(j)+bn*pi(j)) + p=(-1)**(n-1) + t=(-1)**n + + if (j.eq.jj) goto 789 + s1(jj)=s1(jj)+fn*(an*pi(j)*p+bn*tau(j)*t) + s2(jj)=s2(jj)+fn*(an*tau(j)*t+bn*pi(j)*p) + 789 continue + + psi0=psi1 + psi1=psi + apsi1=psi1 ! double prec=simple + + chi0=chi1 + chi1=chi + xi1=cmplx(apsi1,-chi1) + + n=n+1 + rn=n + + do 999 j=1,nang + pi1(j)=((2.*rn-1.)/(rn-1.))*amu(j)*pi(j) + pi1(j)=pi1(j)-rn*pi0(j)/(rn-1.) + 999 pi0(j)=pi(j) + + if (n-1-nstop) 200,300,300 + 300 qsca=(2./(x*x))*qsca + qext=(4./(x*x))*real(s1(1)) + + return + end + + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/cnuages3D.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cnuages3D.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cnuages3D.F (revision 1643) @@ -0,0 +1,434 @@ + subroutine cnuages( + & tq,tqc1,tqc2,tqc3,tqcn,gaz1,gaz2,gaz3, ! aerosol/glace/gas + & ddt) + +c +c +c ° +c ° +c SERT A APPELE LA ROUTINE MICROPHYSIQUE DES NUAGES +c +c ° +c ICI ON NE FAIT QUE LA NUCLEATION/CONDENSATION +c ET GESTION°DES NOYAUX. LA SEDIMENTATION EST DANS +c SNUAGES.F +c ° ° +c +c ° +c ° +c ° ° +c +c ° ° +c ° +c ° ° +c ° \|/ ° +c (@ @)° +c-----------------oOo--O--oOo-------------------------- +c +c +c +c Interface entre physiq.F et les routines n_.F +c +c Date: 3 Nov 2003 +c +c EN ENTREE/SORTIE DE LA ROUTINE +c ------------------------------------ +c +c Les aerosols, noyaux (tq,tqcn) sont en nbre/m^2 dans la colonne +c Les condensats (tqc1,tqc2) sont en volume/m^2 dans la colonne +c Le gaz (gaz1, gaz2) est en fraction molaire +c +c EN APPEL DES ROUTINES NUAGES +c ------------------------------------ +c +c Les aerosols et noyaux doivent etre en nombre /kg d'air +c Les condensats doivent etre en volume / kg d'air +c Le gaz en kg/kg d'air +c +c LES TENDANCES ET DIFFERENCES SONT HOMOGENES AUX QUANTITES +c ------------------------------------------------------------ +c +c +c------------------------------------------------------ + + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer NG1,NG,NL + parameter (NG1=1,NG=NG1,NL=llm) + +c************************************* +c declaration des variables internes * +c************************************* + +c INTERNE! * +c-----------------------* + + real tqc1(NG,NL,nrad) + real tqc2(NG,NL,nrad) + real tqc3(NG,NL,nrad) + real tqcn(NG,NL,nrad) + real tq(NG,NL,nrad) +* + real tdqc1(NG,NL,nrad) + real tdqc2(NG,NL,nrad) + real tdqc3(NG,NL,nrad) + real tdq(NG,NL,nrad,ntype-2+1) + real tdqcn(NG,NL,nrad,ntype-2+1) +* + real gaz1(NG,NL) + real gaz2(NG,NL) + real gaz3(NG,NL) + real dgaz1(NG,NL) + real dgaz2(NG,NL) + real dgaz3(NG,NL) +* + real ppch4(NG,NL) + real ppc2h6(NG,NL) + real ppn2(NG,NL) +* + real pmixch4(NL) + real pmixc2h6(NL) + real pmixn2(NL) +c composition initiale estimée (interne) + real xprime1(NG,NL) + real xprime2(NG,NL) + real xprime3(NG,NL) +c composition calculée (output) + real x1(NL) + real x2(NL) + real x3(NL) +c moyenne "glissante" pondéréee (output + mémoire) + real x1o(NL) + real x2o(NL) + real x3o(NL) + real icefrac(NL) + real dmn2(NL+1) + + real ppch4t,ppc2h6t,ppn2t + real psatch4,psatc2h6,psatn2 + real xprime(3),x(3),frac + real melange + real sum,sum0 + +* RAPPEL: NG=1 + + real ddt + real masspaer + + common/mixing/x1,x2,x3,icefrac, + & pmixch4,pmixc2h6,pmixn2, + & x1o,x2o,x3o + + + +c FORMAT MICRO DES NUAGES +c------------------------* + + real especes(NG,NL,3*nrad+1) + real condens(NG,NL,nrad) + real gg(NL),xmair + real effg ! effg est une fonction(z), z en m. + + integer jsup,jinf,h,i,j,k,ndim + integer ival1,ival2,ival3 + + integer iprem + + save iprem,xprime + data iprem/0/ + + ndim=3*nrad+1 + + do j=1,NL + gg(j)=effg(z(j)) + enddo + +********************************************* +********************************************* +* Appel de la condensation du methane +********************************************* +********************************************* + + + +*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +* Bilan avant sur le methane * +*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + do i=1,ng1 ! ng1=1 !! + do j=1,NL + +* RAZ des delta d'especes communes. +*---------------------------------- + do k=1,nrad + tdqcn(i,j,k,1)= 0. + tdq( i,j,k,1) = 0. + enddo + + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + + do k=1,nrad + especes(i,j,k)=tq(i,j,k) /xmair ! aerosols, noyaux, + especes(i,j,k+nrad)=tqc1(i,j,k) /xmair ! methane condense, + condens(i,j,k)=(tqc2(i,j,k)+tqc3(i,j,k))/xmair! autre(s) condensat(s) + especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair ! nombre/kg & volume/kg + enddo + especes(i,j,3*nrad+1)=gaz1(i,j)*mch4/mair ! methane gazeux kg/kg + enddo + enddo + + +1001 format(7(1x,e12.6),' avN2CH4C2H6') +1003 format(7(1x,e12.6),' miN2CH4C2H6') +1002 format(7(1x,e12.6),' apN2CH4C2H6') +* + call n_methane(ng1,ndim,nrad,ddt, + & p,t,r_e,especes,condens) + + +*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +* Bilan apres sur le methane * +*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + do i=1,ng1 + do j=1,NL + + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + +* ici ce sont les tendances a sortir de nuages.F pour le methane.... +*------------------------------------------------------------------- + sum=0. + do k=1,nrad + tdqc1(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc1(i,j,k) ) + sum =sum+tdqc1(i,j,k)/xmair*rhoi_ch4 + tqc1(i,j,k) = especes(i,j,k+nrad)*xmair + enddo + + dgaz1(i,j)= especes(i,j,3*nrad+1)*mair/mch4-gaz1(i,j) + gaz1(i,j)= especes(i,j,3*nrad+1)*mair/mch4 + +c dgaz1(i,j)=-sum*xmuair/16. +c gaz1(i,j)=gaz1(i,j)+dgaz1(i,j) + +* Premiere tendance sur les variables communes (aerosols et noyaux) +*------------------------------------------------------------------ + do k=1,nrad + tdqcn(i,j,k,1)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k)) + tdq( i,j,k,1) =(especes(i,j,k)*xmair -tq(i,j,k)) + enddo + enddo + enddo + + + +* attention, si il y a de l'ethane sur les noyaux... il est impossible +* de les restituer - en revanche on peut en creer de nouveaux ! !! +* Le corrolaire de la condition ci dessus est que si il est impossible de +* restituer des noyaux, le nombre d'aeorsols ne peux pas augmenter, il +* peut en revanche diminuer + + +********************************************* +********************************************* +* Appel de la condensation de l'ethane +********************************************* +********************************************* + + do i=1,ng1 + do j=1,NL + do k=1,nrad + tdqcn(i,j,k,2)= 0. + tdq( i,j,k,2) = 0. + enddo + + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + + do k=1,nrad + especes(i,j,k)=tq(i,j,k)/xmair + especes(i,j,k+nrad)=tqc2(i,j,k)/xmair ! ethane condense + condens(i,j,k)=(tqc1(i,j,k)+tqc3(i,j,k))/xmair ! autres condensats + especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair + enddo + + especes(i,j,3*nrad+1)=gaz2(i,j)*mc2h6/mair ! ethane gazeux + + enddo + enddo + + + + call n_ethane(ng1,ndim,nrad,ddt, + & p,t,r_e,especes,condens) + + do i=1,ng1 + do j=1,NL + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + +* ici ce sont les tendances a sortir de nuages.F pour l'ethane.... +*----------------------------------------------------------------- + + sum=0. + do k=1,nrad + tdqc2(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc2(i,j,k) ) + sum =sum+tdqc2(i,j,k)/xmair*rhoi_c2h6 + tqc2(i,j,k) = especes(i,j,k+nrad)*xmair + enddo + + dgaz2(i,j)=especes(i,j,3*nrad+1)*mair/mc2h6 - gaz2(i,j) + gaz2(i,j)=especes(i,j,3*nrad+1)*mair/mc2h6 + +c dgaz2(i,j)=-sum*xmuair/30. +c gaz2(i,j)=gaz2(i,j)+dgaz2(i,j) + + +* Deuxieme tendance sur les variables communes (aerosols et noyaux) +*------------------------------------------------------------------ + + do k=1,nrad + tdqcn(i,j,k,2)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k)) + tdq(i,j,k,2) =(especes(i,j,k)*xmair -tq(i,j,k)) + enddo + + enddo + enddo + + +********************************************* +********************************************* +* Appel de la condensation de l'acethylene +********************************************* +********************************************* + + do i=1,ng1 + do j=1,NL + do k=1,nrad + tdqcn(i,j,k,3)= 0. + tdq( i,j,k,3) = 0. + enddo + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + + do k=1,nrad + especes(i,j,k)=tq(i,j,k)/xmair + especes(i,j,k+nrad)=tqc3(i,j,k)/xmair ! acethylene condense + condens(i,j,k)=(tqc1(i,j,k)+tqc2(i,j,k))/xmair ! autres condensats + especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair + enddo + + especes(i,j,3*nrad+1)=gaz3(i,j)*mc2h2/mair ! acethylene gazeux + + enddo + enddo + + call n_acethylene(ng1,ndim,nrad,ddt, + & p,t,r_e,especes,condens) + + + do i=1,ng1 + do j=1,NL + + xmair=(pb(j+1)-pb(j))/gg(j)/dzb(j) + +* ici ce sont les tendances a sortir de nuages.F pour l'ethane.... +*----------------------------------------------------------------- + + sum=0. + do k=1,nrad + tdqc3(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc3(i,j,k) ) + sum =sum+tdqc3(i,j,k)/xmair*rhoi_c2h2 + tqc3(i,j,k) = especes(i,j,k+nrad)*xmair + enddo + + dgaz3(i,j)=especes(i,j,3*nrad+1)*mair/mc2h2 - gaz3(i,j) + gaz3(i,j)=especes(i,j,3*nrad+1)*mair/mc2h2 + +c dgaz3(i,j)=-sum*xmuair/26. +c gaz3(i,j)=gaz3(i,j)+dgaz3(i,j) + +* Troisieme tendance sur les variables communes (aerosols et noyaux) +*------------------------------------------------------------------ + + + do k=1,nrad + tdqcn(i,j,k,3)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k)) + tdq(i,j,k,3) =(especes(i,j,k)*xmair -tq(i,j,k)) + enddo + + enddo + enddo + + +* FIN DES APPELS DE NUAGES ET BILAN DES TENDANCES... +*------------------------------------------------------------------ + + + do i=1,ng1 + do j=1,NL + do k=1,nrad + +* Ici on test l'activité nuageuse : si on a l'association +* tdqcX(i,j,k) = 0 et tqcX(i,j,k) = 0 alors ivalX reste à 0 (pas d'ativité) +* sinon ivalX passe à 1 (activité) +*------------------------------------------------------------------------------------ + + ival1=0 + ival2=0 + ival3=0 + + if(tdqc1(i,j,k).ne.0. .or. tqc1(i,j,k).gt.0.) ival1=1 + if(tdqc2(i,j,k).ne.0. .or. tqc2(i,j,k).gt.0.) ival2=1 + if(tdqc3(i,j,k).ne.0. .or. tqc3(i,j,k).gt.0.) ival3=1 + +* Ici on definit la tendances des noyaux en faisant deux choses: +* -1 On ecarte les cas tdqcn(i,j,k,X)=0 si ils sont associés à une +* absence d'activité nuageuse de l'espèce (tdqcX(i,j,k)=0.) +* -2 Sélectionne la tendance la plus élevée. Si aucune activité nuageuse +* n'exits dans cette case (ivalX=0 pour les 3 especes), alors on +* retrouve la valeur -1.e40 que l'on mets alors à 0. +*---------------------------------------------------------------------- +c23456789012345678901234567890123456789012345678901234567890123456789012 + + tdqcn(i,j,k,ntype-1)=-1.e40 ! plus petite valeur possible + + if(ival1.eq.1.and. + & tdqcn(i,j,k,1).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 1 + & tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,1) + if(ival2.eq.1.and. + & tdqcn(i,j,k,2).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 2 + & tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,2) + if(ival3.eq.1.and. + & tdqcn(i,j,k,3).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 3 + & tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,3) + + if(tdqcn(i,j,k,ntype-1).le.-0.99e39) + & tdqcn(i,j,k,ntype-1)=0. + + tdq(i,j,k,ntype-1)=1.e40 ! plus grande valeur possible + + if(ival1.eq.1 .and. tdq(i,j,k,1).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 1 + & tdq(i,j,k,ntype-1)=tdq(i,j,k,1) + if(ival2.eq.1 .and. tdq(i,j,k,2).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 2 + & tdq(i,j,k,ntype-1)=tdq(i,j,k,2) + if(ival3.eq.1 .and. tdq(i,j,k,3).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 3 + & tdq(i,j,k,ntype-1)=tdq(i,j,k,3) + + if(tdq(i,j,k,ntype-1).ge.0.99e39) tdq(i,j,k,ntype-1)=0. + + tqcn(i,j,k)=tqcn(i,j,k)+tdqcn(i,j,k,ntype-1) ! Alors on ajoute les tendances (positive pour qcn ?) + tq(i,j,k) =tq(i,j,k) +tdq(i,j,k,ntype-1) ! + + if(tqcn(i,j,k).le.0.) tqcn(i,j,k)=0. ! et on régularise les tableaux noyaux et aerosols. + if(tq(i,j,k) .le.0.) tq(i,j,k)=0. ! + + enddo + enddo + enddo + + continue + +1202 format(i2,1x,i2,6(1x,e12.4) ) + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/coefkzmin.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/coefkzmin.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/coefkzmin.F (revision 1643) @@ -0,0 +1,135 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/coefkzmin.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $ +! + SUBROUTINE coefkzmin(ngrid,ypaprs,ypplay,yu,yv,yt,ycoefm + . ,km,kn) +c SUBROUTINE coefkzmin(ngrid,zlev,teta,ustar,km,kn) + + use dimphy + IMPLICIT NONE + +#include "YOMCST.h" + +c....................................................................... +c Entrees modifies en attendant une version ou les zlev, et zlay soient +c disponibles. + + REAL ycoefm(klon,klev) + + REAL yu(klon,klev), yv(klon,klev) + REAL yt(klon,klev) + REAL ypaprs(klon,klev+1), ypplay(klon,klev) + REAL yustar(klon) + real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev) + + integer i + +c....................................................................... +c +c En entree : +c ----------- +c +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c ustar : u* +c +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c +c en sortier : +c ------------ +c +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL teta(klon,klev) + + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + integer l_mix,ngrid + + + integer ig,k + + real kap + save kap + data kap/0.4/ + +c....................................................................... +c en attendant une version ou les zlev, et zlay soient +c disponibles. +c Debut de la partie qui doit etre unclue a terme dans clmain. +c + do i=1,ngrid + yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1))) + . *(ypaprs(i,1)-ypplay(i,1))/RG + enddo + do k=2,klev + do i=1,ngrid + yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) + s /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG + enddo + enddo + do k=1,klev + do i=1,ngrid +cATTENTION:on passe la temperature potentielle virt. pour le calcul de K + yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa + enddo + enddo + do i=1,ngrid + yzlev(i,1)=0. + yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1) + enddo + do k=2,klev + do i=1,ngrid + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + enddo + enddo + + +cIM cf FH yustar(:) =SQRT(ycoefm(:,1)*(yu(:,1)*yu(:,1)+yv(:,1)*yv(:,1))) + yustar(1:ngrid) =SQRT(ycoefm(1:ngrid,1)* + $ (yu(1:ngrid,1)*yu(1:ngrid,1)+yv(1:ngrid,1)*yv(1:ngrid,1))) + +c Fin de la partie qui doit etre unclue a terme dans clmain. + +Cette routine est ecrite pour avoir en entree ustar, teta et zlev +c Ici, on a inclut le calcul de ces trois variables dans la routine +c coefkzmin en attendant une nouvelle version de la couche limite +c ou ces variables seront disponibles. + +c Debut de la routine coefkzmin proprement dite. + + ustar=yustar + teta=yteta + zlev=yzlev + + do ig=1,ngrid + coriol(ig)=1.e-4 + pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5) + enddo + + do k=2,klev + do ig=1,ngrid + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=0. ! kmin n'est utilise que pour les SL stables. + endif + kn(ig,k)=kmin + km(ig,k)=kmin + enddo + enddo + + + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/comcstfi.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/comcstfi.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/comcstfi.h (revision 1643) @@ -0,0 +1,8 @@ +c----------------------------------------------------------------------- +c INCLUDE comcstfi.h + + COMMON/comcstfi/rad,g,r,rcp,dtphys,daysec,mugaz,omeg + + REAL rad,g,r,rcp,dtphys,daysec,mugaz,omeg + +c----------------------------------------------------------------------- Index: trunk/LMDZ.TITAN.old/libf/phytitan/common_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/common_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/common_mod.F90 (revision 1643) @@ -0,0 +1,118 @@ + MODULE common_mod +! Variables sauvegardees - anciens common +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + USE dimphy + implicit none +#include "dimensions.h" + +! ancien rnuabar + REAL, ALLOCATABLE, SAVE :: rmcbar(:,:),xfbar(:,:,:) + INTEGER, ALLOCATABLE, SAVE :: ncount(:,:) +!$OMP THREADPRIVATE(rmcbar,xfbar) +!$OMP THREADPRIVATE(ncount) + +! Common de aerprod.h... aerprod et htoh2 +! Etaient utilises par calchim et la microphysique pour echanger +! des variables pour la production des aerosols par la chimie +! et la chimie heterogene de H a la surface des aerosols +! Ca a disparu de la microphysique... +! A remettre si on veut reutiliser cette fonctionnalite + +! ancien aerprod + INTEGER, SAVE :: utilaer(16) + REAL, ALLOCATABLE, SAVE :: maer(:,:,:),prodaer(:,:,:) + REAL, ALLOCATABLE, SAVE :: csn(:,:,:),csh(:,:,:) +!$OMP THREADPRIVATE(utilaer) +!$OMP THREADPRIVATE(maer,prodaer,csn,csh) +! ancien htoh2 + REAL, ALLOCATABLE, SAVE :: psurfhaze(:,:) +!$OMP THREADPRIVATE(psurfhaze) + +! ancien titan_for.h + INTEGER, PARAMETER :: NLEV=llm+70,NC=44,ND=54,NR=377 +!$OMP THREADPRIVATE(NLEV,NC,ND,NR) +!!! doivent etre en accord avec titan.h +! pour l'UV (650 niveaux de 2 km) + INTEGER, PARAMETER :: NLRT=650 + +! ancien diagmuphy.h +! toutes les variables +! diagnostiques sorties de la microphysique. + +! ---- flux de glace (1:CH4 / 2:C2H6 / 3:C2H2) + REAL, ALLOCATABLE, SAVE :: flxesp_i(:,:,:) +!$OMP THREADPRIVATE(flxesp_i) +! ---- taux sedimentation gouttes, aerosols sec + REAL, ALLOCATABLE, SAVE :: tau_drop(:,:),tau_aer(:,:,:) +!$OMP THREADPRIVATE(tau_drop,tau_aer) +! ---- Production de glace (negatif si disparition) + REAL, ALLOCATABLE, SAVE :: solesp(:,:,:) +!$OMP THREADPRIVATE(solesp) +! ---- Evaporation CH4 + REAL, ALLOCATABLE, SAVE :: evapch4(:) +!$OMP THREADPRIVATE(evapch4) +! ---- occurences des nuages + REAL, ALLOCATABLE, SAVE :: occcld_m(:,:,:) +!$OMP THREADPRIVATE(occcld_m) +! ---- occcld sert a obtenir les opacités/extinction des nuages (proxy) + REAL, ALLOCATABLE, SAVE :: occcld(:,:) +!$OMP THREADPRIVATE(occcld) +! ---- saturation CH4,C2H6,C2H2 + REAL, ALLOCATABLE, SAVE :: satch4(:,:),satc2h6(:,:),satc2h2(:,:) +!$OMP THREADPRIVATE(satch4,satc2h6,satc2h2) +! ---- precipitations (CH4, C2H6, C2H2, noyaux, aerosols) + REAL, ALLOCATABLE, SAVE :: precip(:,:) +!$OMP THREADPRIVATE(precip) +! ---- rayon moyen des gouttes + REAL, ALLOCATABLE, SAVE :: rmcloud(:,:) +!$OMP THREADPRIVATE(rmcloud) + +! Anciently /TAUD/ + REAL, ALLOCATABLE, SAVE :: TauHID(:,:,:) ! cumulative Haze IR opacity + REAL, ALLOCATABLE, SAVE :: TauCID(:,:,:) ! cumulative Clouds IR opacity + REAL, ALLOCATABLE, SAVE :: TauGID(:,:,:) ! cumulative Gas IR opacity + REAL, ALLOCATABLE, SAVE :: TauHVD(:,:,:) ! cumulative Haze Vis opacity + REAL, ALLOCATABLE, SAVE :: TauCVD(:,:,:) ! cumulative Clouds Vis opacity + REAL, ALLOCATABLE, SAVE :: TauGVD(:,:,:) ! cumulative Gas Vis opacity +!$OMP THREADPRIVATE(TauHID,TauCID,TauGID) +!$OMP THREADPRIVATE(TauHVD,TauCVD,TauGVD) +! besoin en plus en l'absence de racommon_h + INTEGER,PARAMETER :: NSPECI=46,NSPECV=24 + +CONTAINS + +!====================================================================== +SUBROUTINE common_init +use dimphy +IMPLICIT NONE +#include "microtab.h" + + ALLOCATE(rmcbar(klon,klev),xfbar(klon,klev,4)) + ALLOCATE(ncount(klon,klev)) + + ALLOCATE(maer(klon,klev,4),prodaer(klon,klev,4)) + ALLOCATE(csn(klon,klev,4),csh(klon,klev,4)) + ALLOCATE(psurfhaze(klon,klev)) + + ALLOCATE(flxesp_i(klon,klev,3),tau_drop(klon,klev)) + ALLOCATE(tau_aer(klon,klev,nrad),solesp(klon,klev,3)) + ALLOCATE(evapch4(klon),occcld_m(klon,klev,12)) + ALLOCATE(occcld(klon,klev),satch4(klon,klev)) + ALLOCATE(satc2h6(klon,klev),satc2h2(klon,klev)) + ALLOCATE(precip(klon,5),rmcloud(klon,klev)) + + ALLOCATE(TauHID(klon,klev,NSPECI)) + ALLOCATE(TauCID(klon,klev,NSPECI)) + ALLOCATE(TauGID(klon,klev,NSPECI)) + ALLOCATE(TauHVD(klon,klev,NSPECV)) + ALLOCATE(TauCVD(klon,klev,NSPECV)) + ALLOCATE(TauGVD(klon,klev,NSPECV)) + +END SUBROUTINE common_init + +!====================================================================== + END MODULE common_mod Index: trunk/LMDZ.TITAN.old/libf/phytitan/comorbit.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/comorbit.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/comorbit.h (revision 1643) @@ -0,0 +1,16 @@ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!..include comorbit.h + + REAL aphelie,periheli,year_day + REAL peri_day,timeperi,obliquit + REAL e_elips,p_elips,unitastr,pi + + COMMON/comorbit/aphelie,periheli,year_day, & + & peri_day,timeperi,obliquit, & + & e_elips,p_elips,unitastr,pi + Index: trunk/LMDZ.TITAN.old/libf/phytitan/compbl.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/compbl.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/compbl.h (revision 1643) @@ -0,0 +1,2 @@ + integer iflag_pbl + common/compbl/iflag_pbl Index: trunk/LMDZ.TITAN.old/libf/phytitan/conf_dat2d.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/conf_dat2d.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/conf_dat2d.F (revision 1643) @@ -0,0 +1,221 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , + , interbar ) +c +c Auteur : P. Le Van + +c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que +c qu'on ait - pi a pi en longitude +c et qu'on ait pi/2. a - pi/2. en latitude +c +c xd et yd sont les longitudes et latitudes initiales +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . + + IMPLICIT NONE + +c *** Arguments en entree *** + INTEGER lons,lats + CHARACTER*25 title + REAL xd(lons),yd(lats) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons),yf(lats) +c +c *** Arguments en entree et sortie *** + REAL champd(lons,lats) + +c *** Variables locales *** +c + REAL pi,pis2,depi + LOGICAL radianlon, invlon ,radianlat, invlat, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: champf(:,:) + +c +c WRITE(6,*) ' conf_dat2d pour la variable ', title + + ALLOCATE( xtemp(lons) ) + ALLOCATE( ytemp(lats) ) + ALLOCATE( champf(lons,lats) ) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + radianlon = .FALSE. + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + IF ( invlon ) THEN + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO j = 1,lats + + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j) = champf (i,j) + ENDDO + + DO i= ind +1,lons + champd (i,j) = champf (i-ind,j) + ENDDO + + ENDDO + + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + DO j = 1,lats + yf(j) = ytemp(j) + ENDDO + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1) = champf (i,j) + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** + +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + + ENDIF +c + DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + deallocate(xtemp) + deallocate(ytemp) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/conf_phys.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/conf_phys.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/conf_phys.F90 (revision 1643) @@ -0,0 +1,517 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/conf_phys.F90,v 1.3 2005/02/07 15:15:31 fairhead Exp $ +! +! +! + + subroutine conf_phys(ok_mensuel,ok_journe,ok_instan,if_ebil) + + use IOIPSL + implicit none + +#include "YOMCST.h" +#include "clesphys.h" +#include "compbl.h" +#include "comorbit.h" + +! ok_journe: sorties journalieres +! ok_mensuel: sorties mensuelles +! ok_instan: sorties instantanees + + +! Sortie: + logical :: ok_journe, ok_mensuel, ok_instan + integer :: if_ebil + +! Local + integer :: numout = 6 + +! +! Configuration de la "physique" de LMDZ a l'aide de la fonction +! GETIN de IOIPSL +! +! LF 05/2001 +! +!--- Ca lit le physiq.def --- + +!******************* parametres anciennement lus dans gcm.def + +!Config Key = cycle_diurne +!Config Desc = Cycle ddiurne +!Config Def = y +!Config Help = Cette option permet d'eteidre le cycle diurne. +!Config Peut etre util pour accelerer le code ! + cycle_diurne = .TRUE. + CALL getin('cycle_diurne',cycle_diurne) + +!Config Key = soil_model +!Config Desc = Modele de sol +!Config Def = y +!Config Help = Choix du modele de sol (Thermique ?) +!Config Option qui pourait un string afin de pouvoir +!Config plus de choix ! Ou meme une liste d'options ! + soil_model = .TRUE. + CALL getin('soil_model',soil_model) + +!Config Key = ok_orodr +!Config Desc = Oro drag +!Config Def = y +!Config Help = GW drag orographie +!Config + ok_orodr = .TRUE. + CALL getin('ok_orodr',ok_orodr) + +!Config Key = ok_orolf +!Config Desc = Oro lift +!Config Def = n +!Config Help = GW lift orographie (pas utilise) + ok_orolf = .TRUE. + CALL getin('ok_orolf', ok_orolf) + +!Config Key = ok_gw_nonoro +!Config Desc = Gravity waves parameterization +!Config Def = n +!Config Help = GW drag non-orographique + ok_gw_nonoro = .FALSE. + CALL getin('ok_gw_nonoro',ok_gw_nonoro) + +!Config Key = nbapp_rad +!Config Desc = Frequence d'appel au rayonnement +!Config Def = 12 +!Config Help = Nombre d'appels des routines de rayonnements +!Config par jour. + nbapp_rad = 12 + CALL getin('nbapp_rad',nbapp_rad) + +!Config Key = nbapp_chim +!Config Desc = Frequence d'appel a la chimie +!Config Def = 1 +!Config Help = Nombre d'appels des routines de chimie +!Config par jour. + nbapp_chim = 1 + CALL getin('nbapp_chim',nbapp_chim) + +!Config Key = iflag_con +!Config Desc = Flag de convection +!Config Def = 0 +!Config Help = Flag pour la convection les options suivantes existent : +!Config 0 : ajsec simple (VENUS, TITAN) +!Config 1 pour LMD, +!Config 2 pour Tiedtke, +!Config 3 pour CCM(NCAR) + iflag_con = 0 + CALL getin('iflag_con',iflag_con) + +!******************* fin parametres anciennement lus dans gcm.def + +!Config Key = OK_mensuel +!Config Desc = Pour des sorties mensuelles +!Config Def = .true. +!Config Help = Pour creer le fichier histmth contenant les sorties +! mensuelles +! + ok_mensuel = .true. + call getin('OK_mensuel', ok_mensuel) +! +!Config Key = OK_journe +!Config Desc = Pour des sorties journalieres +!Config Def = .false. +!Config Help = Pour creer le fichier histday contenant les sorties +! journalieres +! + ok_journe = .false. + call getin('OK_journe', ok_journe) +! +!Config Key = OK_instan +!Config Desc = Pour des sorties instantanees +!Config Def = .false. +!Config Help = Pour creer le fichier histins contenant les sorties +! instantanees +! + ok_instan = .false. + call getin('OK_instan', ok_instan) +! +! +!Config Key = ecritphy +!Config Desc = Frequence d'ecriture dans histins +!Config Def = 1 +!Config Help = frequence de l'ecriture du fichier histins +!Config en jours. +! + ecriphy = 1. + CALL getin('ecritphy', ecriphy) +! +!Config Key = if_ebil +!Config Desc = Niveau de sortie pour les diags bilan d'energie +!Config Def = 0 +!Config Help = +! +! + if_ebil = 0 + call getin('if_ebil', if_ebil) +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Constante solaire & Parametres orbitaux +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +! TITAN ! Valeurs par defaut d'apres Fig Tokano. +! +!! +!Config Key = year_day +!Config Desc = Duree de l'annee en jour +!Config Def = +!Config Help = +! + year_day = 673. + call getin('year_day', year_day) +! +!Config Key = peri_day +!Config Desc = position du perihelie en jour +!Config Def = +!Config Help = +! + peri_day = 533. + call getin('peri_day', peri_day) +! +!Config Key = periheli +!Config Desc = Distance au soleil au perihelie +!Config Def = +!Config Help = +! + periheli = 1354.5 + call getin('periheli', periheli) +!! +!Config Key = aphelie +!Config Desc = Distance au soleil a l'aphelie +!Config Def = +!Config Help = +! + aphelie = 1506.0 + call getin('aphelie', aphelie) +!! +!Config Key = obliquit +!Config Desc = Obliquite +!Config Def = +!Config Help = +! + obliquit = 26.7 + call getin('obliquit', obliquit) +! +!Config Key = solaire +!Config Desc = Constante solaire en W/m2 +! VENUS +!Config Def = 2620. +!Config Help = +! + solaire = 2620. + call getin('solaire', solaire) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! PARAMETER FOR THE PLANETARY BOUNDARY LAYER AND SOIL +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!Config Key = iflag_pbl +!Config Desc = +!Config Def = 1 +!Config Help = +! +! 2 = calculs Cd et K simples pour VENUS : +! parametres = z0, lmixmin, ksta (en dur: umin2,ric,cepdu2,karman) +! 1 = calculs Cd et K issus LMDZ Terre +! parametres = ksta, ok_kzmin (et plein d'autres en dur...) +! 6-9 = schema des thermiques Fred + iflag_pbl = 1 + call getin('iflag_pbl',iflag_pbl) + +! +!Config Key = ksta +!Config Desc = +!Config Def = 1.0e-7 +!Config Help = +! + ksta = 1.0e-7 + call getin('ksta',ksta) + +! +!Config Key = z0 +!Config Desc = +!Config Def = 1.0e-2 +!Config Help = +! + z0 = 1.0e-2 + call getin('z0',z0) + +! +!Config Key = lmixmin +!Config Desc = +!Config Def = 35. +!Config Help = +! + lmixmin = 35. + call getin('lmixmin',lmixmin) + +! +!Config Key = ok_kzmin +!Config Desc = +!Config Def = .false. +!Config Help = +! + ok_kzmin = .false. + call getin('ok_kzmin',ok_kzmin) + + +!Config Key = iflag_ajs +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_ajs = 1 + call getin('iflag_ajs',iflag_ajs) + +! +!Config Key = inertie +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie = 2000. + call getin('inertie',inertie) +! +!Config Key = emis +!Config Desc = +!Config Def = 0.95 +!Config Help = +! + emis = 0.95 + call getin('emis',emis) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! parametres CHIMIE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!Config Key = chimi +!Config Desc = +!Config Def = .false. +!Config Help = +! + chimi = .false. + call getin('chimi',chimi) + +! +!Config Key = vchim +!Config Desc = +!Config Def = 1 +!Config Help = +! + vchim = 1 + call getin('vchim',vchim) + +! +!Config Key = aerprod +!Config Desc = +!Config Def = 0 +!Config Help = +! + aerprod = 0 + call getin('aerprod',aerprod) + +! +!Config Key = htoh2 +!Config Desc = +!Config Def = 1 +!Config Help = +! + htoh2 = 1 + call getin('htoh2',htoh2) + +! +!Config Key = ylellouch +!Config Desc = +!Config Def = .true. +!Config Help = +! + ylellouch = .true. + call getin('ylellouch',ylellouch) + +! +!Config Key = hcnrad +!Config Desc = +!Config Def = .false. +!Config Help = +! + hcnrad = .false. + call getin('hcnrad',hcnrad) + +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! parametres MICROPHYSIQUE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!Config Key = microfi +!Config Desc = +!Config Def = 1 +!Config Help = +! + microfi = 1 + call getin('microfi',microfi) + +! +!Config Key = tx +!Config Desc = +!Config Def = 3.5 +!Config Help = +! + tx = 3.5 + call getin('tx',tx) + +! +!Config Key = tcorrect +!Config Desc = +!Config Def = 1. +!Config Help = +! + tcorrect = 1. + call getin('tcorrect',tcorrect) + +! +!Config Key = xvis +!Config Desc = Facteur d ajustement des proprietes vis des aerosols +!Config Def = 1.5 +!Config Help = +! + xvis = 1.0 + call getin('xvis',xvis) +! +!Config Key = xir +!Config Desc = Facteur d ajustement des proprietes IR des aerosols +!Config Def = 0.5 +!Config Help = +! + xir = 1.0 + call getin('xir',xir) +! +!Config Key = p_prodaer +!Config Desc = pressure level for aerosol production (in Pa) +!Config Def = 1. +!Config Help = +! + p_prodaer = 1. + call getin('p_prodaer',p_prodaer) +! +!Config Key = cutoff +!Config Desc = +!Config Def = 2 +!Config Help = +! + cutoff = 2 + call getin('cutoff',cutoff) + +! +!Config Key = clouds +!Config Desc = activation des nuages +!Config Def = 1 +!Config Help = +! + clouds = 1 + call getin('clouds',clouds) + if (microfi.lt.1) clouds = 0 ! On ne fait pas de nuages sans microphysique ! + if (clouds.eq.1) cutoff = 0 ! si nuages, il faut mettre ca + +! +!Config Key = xnuf +!Config Desc = fraction nuageuse +!Config Def = 0.5 +!Config Help = +! + xnuf = 0.5 + call getin('xnuf',xnuf) + xnuf = amax1(xnuf,0.1) ! On garde au minimum 10% de nuages. + if (clouds.eq.0) xnuf = 0. ! Si il n'y pas de nuages, on ne met pas de fraction + ! nuageuse -> permet de retomber sur le TR habituel. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! PARAMETER FOR THE OUTPUT LEVELS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! +!Config Key = lev_histmth +!Config Desc = +!Config Def = 2 +!Config Help = +! + lev_histmth = 2 + call getin('lev_histmth',lev_histmth) + +! +!Config Key = lev_histday +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histday = 1 + call getin('lev_histday',lev_histday) + +! +! +!Config Key = +!Config Desc = +!Config Def = +!Config Help = +! +! = +! call getin('',) +! +! +! +! + + write(numout,*)' ##############################################' + write(numout,*)' Configuration des parametres de la physique: ' + write(numout,*)' cycle_diurne = ', cycle_diurne + write(numout,*)' soil_model = ', soil_model + write(numout,*)' ok_orodr = ', ok_orodr + write(numout,*)' ok_orolf = ', ok_orolf + write(numout,*)' ok_gw_nonoro = ', ok_gw_nonoro + write(numout,*)' nbapp_rad = ', nbapp_rad + write(numout,*)' nbapp_chim = ', nbapp_chim + write(numout,*)' iflag_con = ', iflag_con + write(numout,*)' Sortie mensuelle = ', ok_mensuel + write(numout,*)' Sortie journaliere = ', ok_journe + write(numout,*)' Sortie instantanee = ', ok_instan + write(numout,*)' frequence sorties = ', ecriphy + write(numout,*)' Sortie bilan d energie, if_ebil =', if_ebil + write(numout,*)' Duree de l annee = ',year_day + write(numout,*)' Position du perihelie = ',peri_day + write(numout,*)' Perihelie = ',periheli + write(numout,*)' Aphelie = ',aphelie + write(numout,*)' Obliquite =',obliquit + write(numout,*)' iflag_pbl = ', iflag_pbl + write(numout,*)' z0 = ',z0 + write(numout,*)' lmixmin = ',lmixmin + write(numout,*)' ksta = ',ksta + write(numout,*)' ok_kzmin = ',ok_kzmin + write(numout,*)' inertie = ', inertie + write(numout,*)' emis = ', emis + write(numout,*)' iflag_ajs = ', iflag_ajs + write(numout,*)' chimi = ', chimi + write(numout,*)' vchim = ', vchim + write(numout,*)' aerprod = ', aerprod + write(numout,*)' htoh2 = ', htoh2 + write(numout,*)' ylellouch = ', ylellouch + write(numout,*)' hcnrad = ', hcnrad + write(numout,*)' microfi = ', microfi + write(numout,*)' tx = ', tx + write(numout,*)' tcorrect = ', tcorrect + write(numout,*)' xvis = ', xvis + write(numout,*)' xir = ', xir + write(numout,*)' p_prodaer = ', p_prodaer + write(numout,*)' cutoff = ', cutoff + write(numout,*)' clouds = ', clouds + write(numout,*)' xnuf = ', xnuf + write(numout,*)' lev_histmth = ',lev_histmth + write(numout,*)' lev_histday = ',lev_histday + + return + + end subroutine conf_phys + Index: trunk/LMDZ.TITAN.old/libf/phytitan/cooling.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cooling.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cooling.F (revision 1643) @@ -0,0 +1,339 @@ + SUBROUTINE COOLING(NG,NL,PRESS,TEMP,Z,Q0,zlwup,zlwdn,pfluxi,icld) + +c======================================================================= +c +c Author : C. P. Mc Kay 01/02/91 +c ------ +c +c Object : +c -------- +c +C THIS SUBROUTINE RETURNS THE COOLING RATE IN TITAN'S ATMOSPHERE +C INPUTS ARE PRESS(BARS), TEMP(K), Z(KM) +C OUTPUT IS: Q(K/SEC)C +C +C COOLING RATE COMPUTED NEGLECTING SCATTERING. +C THE TRICK OF THIS ROUTINE IS THAT IT READS IN THE OPACITIES +C FOR EACH LAYER AT EACH WAVENUMBER IN THE SPECTRAL DOMAIN +C THESE OPACITIES ARE HELD CONSTANT WITH TEMPERATURE AND TIME. +c +c Interface: +c ---------- +c +c Arguments: +c ---------- +c +c input: +c ------ +c +c nl number of levels +c press(nl) pressure levels (layers) +c temp(nl) temperature (layers) +c z(nl) altitude (m, levels) +c +c output: +c ------- +c +c q0(nl-1) radiative cooling in K/sec +c zlwup(nl) up fluxes, (+) upward +c zlwdn(nl) down fluxes, (+) downward +c pfluxi IR descendant a la surface (+ vers le bas) +c +c Commons: +c -------- +c +c COMMON/IRTAUS/dtaui(nlayer,nspeci) +c infrared opacities of the differents layers for differents +c spectral ranges. This common is initialized by radtitan. +c +c COMMON /PLANT/ CSUBP,F0PI +c This common is initialized by tgmdat. +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------ + + use dimphy + use tgmdat_mod, only: CSUBP,F0PI + IMPLICIT NONE +#include "dimensions.h" +#include "YOMCST.h" +#include "clesphys.h" + INTEGER NLAYER,NSPECI,NSPC1I + PARAMETER(NLAYER=llm) + PARAMETER (NSPECI=46,NSPC1I=47) + +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c +c Arguments: +c ---------- + + INTEGER NG,NL,icld + REAL PRESS(NG,NL),TEMP(NG,NL) + REAL Z(NG,NL),Q0(NG,NL-1) + REAL zlwup(NG,NL),zlwdn(NG,NL),UBARI2 + real pfluxi(NG) + + +c Common: +c ------- + +C DTAU IS PASSED EN-MASS, SO ITS DEMENSIONS ARE CRITICAL + REAL dtaui(ngrid,NLAYER,NSPECI) + REAL dtauip(ngrid,NLAYER,NSPECI) + COMMON /IRTAUS/ dtaui,dtauip + +c Local: +c ------ + + REAL WNOI(NSPECI),DWNI(NSPECI) ! SPECTAL INTERVALS + REAL B0(ngrid,llm+1) + REAL EM(ngrid,llm+1) + REAL DW,WAVEN,TJ,BSURF,QOUT,QIN,eff_g,COLDEN + + INTEGER ig,K,J,I,L + +c EXTERNAL PLNCK + REAL PLNCK,zz1,zz2,zz3,zz4,WAVNUM,Xtest + + REAL FNETIS(ngrid,llm+1),FNETI(ngrid,llm+1) + REAL FDIS(ngrid,llm+1,nspeci),FUPIS(ngrid,llm+1,nspeci) + REAL FDI(ngrid,llm+1), FUPI(ngrid,llm+1) + +c Data: +c ----- + + REAL RHOP,UBARI + DATA RHOP/1.E4/ ! CONVERSION FROM PRESSURE TO MASS + DATA UBARI/0.5/ ! MEAN COSINE FOR 2-STREAM + DATA WNOI/ + & 11.500, 20.000, 31.250, 50.000, 75.000, + & 100.000, 125.000, 150.000, 175.000, 200.000, + & 225.000, 250.000, 275.000, 300.000, 325.000, + & 350.000, 375.000, 400.000, 425.000, 450.000, + & 475.000, 500.000, 525.000, 550.000, 575.000, + & 600.000, 628.750, 662.838, 681.757, 683.919, + & 686.541, 689.623, 692.704, 695.786, 715.141, + & 733.836, 735.597, 737.358, 739.119, 742.720, + & 748.160, 753.600, 834.560, 917.333, 926.400, + & 935.466/ + DATA DWNI/ + & 7.000, 10.000, 12.500, 25.000, 25.000, + & 25.000, 25.000, 25.000, 25.000, 25.000, + & 25.000, 25.000, 25.000, 25.000, 25.000, + & 25.000, 25.000, 25.000, 25.000, 25.000, + & 25.000, 25.000, 25.000, 25.000, 25.000, + & 25.000, 32.500, 35.676, 2.162, 2.162, + & 3.082, 3.082, 3.082, 3.082, 35.629, + & 1.761, 1.761, 1.761, 1.761, 5.440, + & 5.440, 5.440, 156.480, 9.067, 9.067, + & 9.067/ + + + save RHOP,UBARI,WNOI,DWNI + + REAL effg ! effg est une fonction(z en m) + +c----------------------------------------------------------------------- + +c Initialisations: +c ---------------- + + UBARI2=1./1.66 + UBARI2=UBARI + +C ZERO THE FLUXES + Q0 = 0.0 + zlwup = 0.0 + zlwdn = 0.0 + +c----------------------------------------------------------------------- +C WE NOW ENTER A MAJOR LOOP OVER SPECRAL INTERVALS IN THE INFRARED +C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL +c----------------------------------------------------------------------- + + DO 2000 K=1,NSPECI ! *** START OF SPECTRAL LOOP + +c----------------------------------------------------------------------- +C SET UP ALTITIDUE PARAMETERS + + WAVEN=WNOI(K) + DW=DWNI(K) + zz1=DW/(2.*2) + EM = 0. + B0 = 0. + + DO J=1,NL-1 + DO ig=1,NG + TJ=TEMP(ig,J) + + +C Modif: in-lining de la fonction planck pour vectorisation +C B0(ig,J)=PLNCK(WAVEN,TJ,DW) +C FUNCTION PLNCK(WAV,T,DW) +C* PLNCK FUNCTION RETURNS B IN CGS UNITS, ERGS CM-2 WAVENUMBER-1 +C* WAVNUM IS WAVENUMBER IN CM-1 +C* T IS IN KELVIN + PLNCK=0. + DO I=-2,2,1 + WAVNUM=WAVEN + I*zz1 + zz2=EXP(-1.4388 * WAVNUM/TEMP(ig,J)) + zz3=WAVNUM*WAVNUM*WAVNUM + PLNCK=PLNCK+1.191E-5* zz3*zz2/(1.-zz2) + ENDDO + B0(ig,J)=.2*PLNCK + ENDDO + + IF (ICLD.EQ.1) THEN + DO ig=1,NG + zz4=EXP(-DTAUI(ig,J,K)/UBARI2) + EM(ig,J)=zz4 + ENDDO + ELSE + DO ig=1,NG + zz4=EXP(-DTAUIP(ig,J,K)/UBARI2) + EM(ig,J)=zz4 + ENDDO + ENDIF + ENDDO + +c----------------------------------------------------------------------- +C CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL +C OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY + + FDI =0. + FDIS =0. + FUPI =0. + FUPIS=0. + + DO 2220 J=1,NL-1 + DO 2230 ig=1,NG + FDI(ig,J+1) = FDI(ig,J)*EM(ig,J) + 2.*RPI*UBARI* + & B0(ig,J)*(1.-EM(ig,J)) + FDIS(ig,J+1,K) = FDIS(ig,J,K)*EM(ig,J) + 2.*RPI*UBARI* + & B0(ig,J)*(1.-EM(ig,J)) +2230 CONTINUE +2220 CONTINUE +c write(*,*) +c write(*,*) 'cooling : EM =' , +c & ((EM(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : B0 =' , +c & ((B0(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : FDI =' , +c & ((FDI(i,l),l=1,nl),i=1,ngrid) + +c----------------------------------------------------------------------- +C UPWARD FLUXES: SURFACE EMISSIONS + + DO 2310 ig=1,NG + PLNCK=0. + DO I=-2,2,1 + WAVNUM=WAVEN + I*zz1 + zz2=EXP(-1.4388 * WAVNUM/TEMP(ig,NL)) + zz3=WAVNUM*WAVNUM*WAVNUM + PLNCK=PLNCK+1.191E-5* zz3*zz2/(1.-zz2) + ENDDO +c BSURF=PLNCK( WAVEN, TEMP(ig,NL), DW) + BSURF=.2*PLNCK*emis + FUPI(ig,NL) =BSURF*2.*RPI*UBARI+(1-emis)*FDI(ig,NL) + FUPIS(ig,NL,K)=BSURF*2.*RPI*UBARI+(1-emis)*FDIS(ig,NL,K) +2310 CONTINUE +c write(*,*) +c write(*,*) 'cooling : FUPI/NL =' , +c & ((FUPI(i,l),l=nl,nl),i=1,NG) +c write(*,*) +c write(*,*) 'cooling : FDI/NL =' , +c & ((FDI(i,l),l=nl,nl),i=1,NG) + + DO 2320 J=NL-1,1,-1 + DO 2330 ig=1,NG + FUPI(ig,J) = FUPI(ig,J+1)*EM(ig,J) + 2.*RPI*UBARI* + & B0(ig,J)*(1.-EM(ig,J)) + FUPIS(ig,J,K) = FUPIS(ig,J+1,K)*EM(ig,J)+2.*RPI*UBARI* + & B0(ig,J)*(1.-EM(ig,J)) +2330 CONTINUE +2320 CONTINUE +c write(*,*) +c write(*,*) 'cooling : EM =' , +c & ((EM(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : B0 =' , +c & ((B0(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : FUPI =' , +c & ((FUPI(i,l),l=1,nl),i=1,ngrid) + +c compute the downward IR flux at the surface: +c + DO 3520 ig=1,NG + pfluxi(ig)=pfluxi(ig)+ DWNI(K)*FDI(ig,NL) +3520 CONTINUE + +c compute the up (+ upward) and down (+ downward) IR fluxes: +c + DO J=1,NL + DO ig=1,NG + zlwup(ig,J)= zlwup(ig,J)+ DWNI(K)*FUPI(ig,J) + zlwdn(ig,J)= zlwdn(ig,J)+ DWNI(K)*FDI(ig,J) + ENDDO + ENDDO + + DO 3210 J=1,NL-1 + DO 3220 ig=1,NG + QOUT=FUPI(ig,J) + FDI(ig,J+1) ! OUT OF LAYER + QIN =FDI(ig,J) + FUPI(ig,J+1) ! INTO LAYER + Q0(ig,J)=Q0(ig,J)+(QOUT-QIN)*DWNI(K) +3220 CONTINUE +3210 CONTINUE + +c write(*,*) +c write(*,*) 'cooling/loop : FUPI =' , +c & ((FUPI(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : FDI =' , +c & ((FDI(i,l),l=1,nl),i=1,ngrid) +c write(*,*) +c write(*,*) 'cooling : Q0 =' , +c & ((Q0(i,l),l=1,nl-1),i=1,ngrid) + + +c----------------------------------------------------------------------- + +2000 CONTINUE ! *** END SPECTRAL INTERVAL COMPUTATIONS + + +c----------------------------------------------------------------------- + +c convertion erg/cm2 -> J/m2 + DO 3550 ig=1,NG + pfluxi(ig) = 1.e-3*pfluxi(ig) + zlwup(ig,:) = 1.e-3*zlwup(ig,:) + zlwdn(ig,:) = 1.e-3*zlwdn(ig,:) +3550 CONTINUE + +c PRINT*,'flux IR' +c WRITE(*,'(8e10.2)') pfluxi + +C COMPUTE THE BASELINE COOLING RATE + + DO 3000 J=1,NL-1 +C TURN THE Q'S INTO TIMESCALES..... + DO 3300 ig=1,NG + COLDEN = RHOP*(PRESS(ig,J+1)-PRESS(ig,J))/effg(Z(ig,J)) +c Q0(J) = (COLDEN * CSUBP )/Q0(J) + Q0(ig,J) = Q0(ig,J) / (COLDEN*CSUBP) +3300 CONTINUE +3000 CONTINUE + +c write(*,*) +c write(*,*) 'cooling/end : Q0 =' +c write(*,*) ((Q0(k,l)*1e7,l=1,nl-1),k=1,ngrid) +c----------------------------------------------------------------------- + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/cpdet_phy_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/cpdet_phy_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/cpdet_phy_mod.F90 (revision 1643) @@ -0,0 +1,78 @@ +module cpdet_phy_mod + +implicit none + +real,save :: cpp ! reference Cp + +contains + + SUBROUTINE init_cpdet_phy(cpp_) + ! initialize module variables + REAL,INTENT(IN) :: cpp_ ! cpp from dynamics + + cpp=cpp_ + + END SUBROUTINE init_cpdet_phy + +!====================================================================== + + FUNCTION cpdet(t) + + IMPLICIT none + +! for now in Titan Cp does not change with temperature + + real,intent(in) :: t + real cpdet + + cpdet = cpp + + end function cpdet + +!====================================================================== + + SUBROUTINE t2tpot(npoints, yt, yteta, ypk) +!====================================================================== +! Arguments: +! +! yt --------input-R- Temperature +! yteta-------output-R- Temperature potentielle +! ypk --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA +! +!====================================================================== + + IMPLICIT NONE + + integer,intent(in) :: npoints + REAL,intent(in) :: yt(npoints), ypk(npoints) + REAL,intent(out) :: yteta(npoints) + + yteta = yt * cpp/ypk + + end subroutine t2tpot + +!====================================================================== + + SUBROUTINE tpot2t(npoints,yteta, yt, ypk) +!====================================================================== +! Arguments: +! +! yteta--------input-R- Temperature potentielle +! yt -------output-R- Temperature +! ypk --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA +! +!====================================================================== + + IMPLICIT NONE + + integer,intent(in) :: npoints + REAL,intent(in) :: yteta(npoints), ypk(npoints) + REAL,intent(out) :: yt(npoints) + + yt = yteta * ypk/cpp + + end subroutine tpot2t + +!====================================================================== + +end module cpdet_phy_mod Index: trunk/LMDZ.TITAN.old/libf/phytitan/def_var.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/def_var.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/def_var.F90 (revision 1643) @@ -0,0 +1,33 @@ +subroutine def_var(nid,name,title,units,nbdim,dim,nvarid,ierr) + +implicit none + +include "netcdf.inc" + +character (len=*) :: title,units,name +integer :: nid,nbdim,nvarid,ierr +integer, dimension(nbdim) :: dim + +ierr=NF_REDEF(nid) +#ifdef NC_DOUBLE +ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dim,nvarid) +#else +ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dim,nvarid) +#endif +if(ierr/=NF_NOERR) then + write(*,*) NF_STRERROR(ierr) + stop "in def_var" +endif +ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", len_trim(adjustl(title)),adjustl(title)) +if(ierr/=NF_NOERR) then + write(*,*) NF_STRERROR(ierr) + stop "in def_var" +endif +ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", len_trim(adjustl(units)),adjustl(units)) +if(ierr/=NF_NOERR) then + write(*,*) NF_STRERROR(ierr) + stop "in def_var" +endif +ierr = NF_ENDDEF(nid) + +end Index: trunk/LMDZ.TITAN.old/libf/phytitan/diagphy.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/diagphy.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/diagphy.F (revision 1643) @@ -0,0 +1,409 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/diagphy.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $ +! + SUBROUTINE diagphy(airephy,tit,iprt + $ , tops, topl, sols, soll, sens + $ , evap, rain_fall, snow_fall, ts + $ , d_etp_tot, d_qt_tot, d_ec_tot + $ , fs_bound, fq_bound) + +! ATTENTION !! PAS DU TOUT A JOUR POUR VENUS OU TITAN... + +C====================================================================== +C +C Purpose: +C Compute the thermal flux and the watter mass flux at the atmosphere +c boundaries. Print them and also the atmospheric enthalpy change and +C the atmospheric mass change. +C +C Arguments: +C airephy-------input-R- grid area +C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15) +C iprt--------input-I- PRINT level ( <=0 : no PRINT) +C tops(klon)--input-R- SW rad. at TOA (W/m2), positive up. +C topl(klon)--input-R- LW rad. at TOA (W/m2), positive down +C sols(klon)--input-R- Net SW flux above surface (W/m2), positive up +C (i.e. -1 * flux absorbed by the surface) +C soll(klon)--input-R- Net LW flux above surface (W/m2), positive up +C (i.e. flux emited - flux absorbed by the surface) +C sens(klon)--input-R- Sensible Flux at surface (W/m2), positive down +C evap(klon)--input-R- Evaporation + sublimation watter vapour mass flux +C (kg/m2/s), positive up +C rain_fall(klon) +C --input-R- Liquid watter mass flux (kg/m2/s), positive down +C snow_fall(klon) +C --input-R- Solid watter mass flux (kg/m2/s), positive down +C ts(klon)----input-R- Surface temperature (K) +C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy +C change (W/m2) +C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass +C change (kg/m2/s) +C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy +C change (W/m2) +C +C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2) +C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s) +C +C J.L. Dufresne, July 2002 +C====================================================================== +C + use dimphy + implicit none + +#include "YOMCST.h" +C +C Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt + real tops(klon),topl(klon),sols(klon),soll(klon) + real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon) + REAL ts(klon) + REAL d_etp_tot, d_qt_tot, d_ec_tot +c Output variables + REAL fs_bound, fq_bound +C +C Local variables + real stops,stopl,ssols,ssoll + real ssens,sfront,slat + real airetot, zcpvap, zcwat, zcice + REAL rain_fall_tot, snow_fall_tot, evap_tot +C + integer i +C + integer pas + save pas + data pas/0/ +C + pas=pas+1 + stops=0. + stopl=0. + ssols=0. + ssoll=0. + ssens=0. + sfront = 0. + evap_tot = 0. + rain_fall_tot = 0. + snow_fall_tot = 0. + airetot=0. +C +C Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de +C la glace, on travaille par difference a la chaleur specifique de l' +c air sec. En effet, comme on travaille a niveau de pression donne, +C toute variation de la masse d'un constituant est totalement +c compense par une variation de masse d'air. +C + zcpvap=RCPV-RCPD + zcwat=RCW-RCPD + zcice=RCS-RCPD +C + do i=1,klon + stops=stops+tops(i)*airephy(i) + stopl=stopl+topl(i)*airephy(i) + ssols=ssols+sols(i)*airephy(i) + ssoll=ssoll+soll(i)*airephy(i) + ssens=ssens+sens(i)*airephy(i) + sfront = sfront + $ + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice + $ ) *ts(i) *airephy(i) + evap_tot = evap_tot + evap(i)*airephy(i) + rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i) + snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i) + airetot=airetot+airephy(i) + enddo + stops=stops/airetot + stopl=stopl/airetot + ssols=ssols/airetot + ssoll=ssoll/airetot + ssens=ssens/airetot + sfront = sfront/airetot + evap_tot = evap_tot /airetot + rain_fall_tot = rain_fall_tot/airetot + snow_fall_tot = snow_fall_tot/airetot +C + slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot +C Heat flux at atm. boundaries + fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront + $ + slat +C Watter flux at atm. boundaries + fq_bound = evap_tot - rain_fall_tot -snow_fall_tot +C + IF (iprt.ge.1) write(6,6666) + $ tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot +C + IF (iprt.ge.1) write(6,6668) + $ tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound +C + IF (iprt.ge.2) write(6,6667) + $ tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot + $ ,rain_fall_tot+snow_fall_tot + + return + + 6666 format('Phys. Flux Budget ',a15,1i6,x,2(f10.2,x),2(1pE13.5)) + 6667 format('Phys. Boundary Flux ',a15,1i6,x,6(f10.2,x),2(1pE13.5)) + 6668 format('Phys. Total Budget ',a15,1i6,x,f10.2,2(1pE13.5)) + + end + +C====================================================================== + SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime + e ,t,q,ql,qs,u,v,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la physique. Suppose que les niveau de +c pression entre couche ne varie pas entre 2 appels. +C +C Plusieurs de ces diagnostics peuvent etre fait en parallele: les +c bilans sont sauvegardes dans des tableaux indices. On parlera +C "d'indice de diagnostic" +c +C +c====================================================================== +C Arguments: +C airephy-------input-R- grid area +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c qs-------input-R- solid watter (kg/kg) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c paprs----input-R- pression a intercouche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_qs------output-R- same, for the solid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C other (COMMON...) +C RCPD, RCPV, .... +C +C J.L. Dufresne, July 2002 +c====================================================================== + + use dimphy + use cpdet_phy_mod, only: cpdet + IMPLICIT NONE +C +#include "YOMCST.h" +C +c Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev) + REAL u(klon,klev), v(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev) +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL zairm(klon,klev) ! layer air mass (kg/m2) + REAL zqw_col(klon) + REAL zql_col(klon) + REAL zqs_col(klon) + REAL zec_col(klon) + REAL zh_dair_col(klon) + REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + +c====================================================================== +C + DO k = 1, klev + DO i = 1, klon +C layer air mass + zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG + ENDDO + END DO +C +C Reset variables + DO i = 1, klon + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, klev + DO i = 1, klon +C Watter mass + zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k) +C Air enthalpy +! ADAPTATION GCM POUR CP(T) + zh_dair_col(i) = zh_dair_col(i) + $ + cpdet(t(i,k))*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*q(i,k)*zairm(i,k)*t(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*ql(i,k)*zairm(i,k)*t(i,k) + $ - RLVTT*ql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*qs(i,k)*zairm(i,k)*t(i,k) + $ - RLSTT*qs(i,k)*zairm(i,k) + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,klon + qw_tot = qw_tot + zqw_col(i)*airephy(i) + ql_tot = ql_tot + zql_col(i)*airephy(i) + qs_tot = qs_tot + zqs_col(i)*airephy(i) + ec_tot = ec_tot + zec_col(i)*airephy(i) + h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i) + h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i) + h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i) + h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i) + airetot=airetot+airephy(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +c print*,'airetot=',airetot,' h_dair_tot=',h_dair_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Phys. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol, h_vcol_tot/dtime + 9001 format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(E14.6,x)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F10.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/dimphy.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dimphy.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dimphy.F90 (revision 1643) @@ -0,0 +1,35 @@ +MODULE dimphy + + INTEGER,SAVE :: klon + INTEGER,SAVE :: kdlon + INTEGER,SAVE :: kfdia + INTEGER,SAVE :: kidia + INTEGER,SAVE :: klev + INTEGER,SAVE :: klevp1 + INTEGER,SAVE :: klevm1 + +!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon) + +CONTAINS + + SUBROUTINE init_dimphy(klon0,klev0) + IMPLICIT NONE + + INTEGER, INTENT(in) :: klon0 + INTEGER, INTENT(in) :: klev0 + + klon=klon0 + + kdlon=klon + kidia=1 + kfdia=klon +!$OMP MASTER + klev=klev0 + klevp1=klev+1 + klevm1=klev-1 +!$OMP END MASTER + + END SUBROUTINE init_dimphy + + +END MODULE dimphy Index: trunk/LMDZ.TITAN.old/libf/phytitan/dimsoil.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dimsoil.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dimsoil.h (revision 1643) @@ -0,0 +1,5 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/dimsoil.h,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $ +! + INTEGER nsoilmx + PARAMETER (nsoilmx=11) Index: trunk/LMDZ.TITAN.old/libf/phytitan/dmiess.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dmiess.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dmiess.F (revision 1643) @@ -0,0 +1,416 @@ + SUBROUTINE DMIESS( RO, RFR, RFI, THETD, JX, + 2 QEXT, QSCAT, CTBRQS, ELTRMX, PI, + 3 TAU, CSTHT, SI2THT, ACAP, IT, + 4 LL, R, RE2, TMAG2, WVNO ) +C +C THIS VERSION OF THE FAMOUS DMIESS CODE IS ADAPTED FOR THE VAX +C ITS ACCURACY HAS BEEN CHECKED BY COMPARISON TO CRAY RUNS. +C -C.P. MCKAY +C + IMPLICIT REAL (A-H,O-Z) +C + COMPLEX FNAP, FNBP, ACAP(LL), W, + 2 FNA, FNB, RF, RRF, + 3 RRFX, WM1, FN1, FN2, + 4 TC1, TC2, WFN(2), Z(4), + 5 K1, K2, K3, SIN, + 6 COS, RC, U(8), DH1, + 7 DH2, DH4, P24H24, P24H21, + 8 PSTORE, HSTORE, DUMMY, DUMSQ +C + DIMENSION W(3,9000) + DIMENSION T(5), TA(4), TB(2), TC(2), + 2 TD(2), TE(2), PI( 3,IT ), TAU( 3,IT ), + 3 CSTHT(IT), THETD(IT), SI2THT(IT), ELTRMX( 4,IT,2 ) +C + EQUIVALENCE ( WFN(1),TA(1) ), ( FNA,TB(1) ), + 2 ( FNB,TC(1) ), ( FNAP,TD(1) ), + 3 ( FNBP,TE(1) ) +C +C +C THIS SUBROUTINE COMPUTES MIE SCATTERING BY A STRATIFIED SPHERE +C I.E. A PARTICLE CONSISTING OF A SPHERICAL CORE SURROUNDED BY A +C SPHERICAL SHELL. THE BASIC CODE USED WAS THAT DESCRIBED IN THE +C REPORT: " SUBROUTINES FOR COMPUTING THE PARAMETERS OF THE +C ELECTROMAGNETIC RADIATION SCATTERED BY A SPHERE " J.V. DAVE, +C I B M SCIENTIFIC CENTER, PALO ALTO , CALIFORNIA. +C REPORT NO. 320 - 3236 .. MAY 1968 . +C +C THE MODIFICATIONS FOR STRATIFIED SPHERES ARE DESCRIBED IN +C TOON AND ACKERMAN, APPL. OPTICS, IN PRESS, 1981 +C +C +C THE PARAMETERS IN THE CALLING STATEMENT ARE DEFINED AS FOLLOWS : +C RO IS THE OUTER (SHELL) RADIUS; +C R IS THE CORE RADIUS; +C RFR, RFI ARE THE REAL AND IMAGINARY PARTS OF THE SHELL INDEX +C OF REFRACTION IN THE FORM (RFR - I* RFI); +C RE2, TMAG2 ARE THE INDEX PARTS FOR THE CORE; +C ( WE ASSUME SPACE HAS UNIT INDEX. ) +C THETD(J): ANGLE IN DEGREES BETWEEN THE DIRECTIONS OF THE INCIDENT +C AND THE SCATTERED RADIATION. THETD(J) IS< OR= 90.0 +C IF THETD(J) SHOULD HAPPEN TO BE GREATER THAN 90.0, ENTER WITH +C SUPPLEMENTARY VALUE, SEE COMMENTS BELOW ON ELTRMX; +C JX: TOTAL NUMBER OF THETD FOR WHICH THE COMPUTATIONS ARE +C REQUIRED. JX SHOULD NOT EXCEED IT UNLESS THE DIMENSIONS +C STATEMENTS ARE APPROPRIATEDLY MODIFIED; +C +C THE DEFINITIONS FOR THE FOLLOWING SYMBOLS CAN BE FOUND IN"LIGHT +C SCATTERING BY SMALL PARTICLES,H.C.VAN DE HULST, JOHN WILEY ' +C SONS, INC., NEW YORK, 1957" . +C QEXT: EFFIECIENCY FACTOR FOR EXTINCTION,VAN DE HULST,P.14 ' 127. +C QSCAT: EFFIECINCY FACTOR FOR SCATTERING,V.D. HULST,P.14 ' 127. +C CTBRQS: AVERAGE(COSINE THETA) * QSCAT,VAN DE HULST,P.128 +C ELTRMX(I,J,K): ELEMENTS OF THE TRANSFORMATION MATRIX F,V.D.HULST +C ,P.34,45 ' 125. I=1: ELEMENT M SUB 2..I=2: ELEMENT M SUB 1.. +C I = 3: ELEMENT S SUB 21.. I = 4: ELEMENT D SUB 21.. +C ELTRMX(I,J,1) REPRESENTS THE ITH ELEMENT OF THE MATRIX FOR +C THE ANGLE THETD(J).. ELTRMX(I,J,2) REPRESENTS THE ITH ELEMENT +C OF THE MATRIX FOR THE ANGLE 180.0 - THETD(J) .. +C +C IT: IS THE DIMENSION OF THETD, ELTRMX, CSTHT, PI, TAU, SI2THT, +C IT MUST CORRESPOND EXACTLY TO THE SECOND DIMENSION OF ELTRMX. +C LL: IS THE DIMENSION OF ACAP +C IN THE ORIGINAL PROGRAM THE DIMENSION OF ACAP WAS 7000. +C FOR CONSERVING SPACE THIS SHOULD BE NOT MUCH HIGHER THAN +C THE VALUE, N=1.1*(NREAL**2 + NIMAG**2)**.5 * X + 1 +C WVNO: 2*PI / WAVELENGTH +C +C THIS SUBROUTINE COMPUTES THE CAPITAL A FUNCTION BY MAKING USE OF +C DOWNWARD RECURRENCE RELATIONSHIP. +C +C TA(1): REAL PART OF WFN(1). TA(2): IMAGINARY PART OF WFN(1). +C TA(3): REAL PART OF WFN(2). TA(4): IMAGINARY PART OF WFN(2). +C TB(1): REAL PART OF FNA. TB(2): IMAGINARY PART OF FNA. +C TC(1): REAL PART OF FNB. TC(2): IMAGINARY PART OF FNB. +C TD(1): REAL PART OF FNAP. TD(2): IMAGINARY PART OF FNAP. +C TE(1): REAL PART OF FNBP. TE(2): IMAGINARY PART OF FNBP. +C FNAP, FNBP ARE THE PRECEDING VALUES OF FNA, FNB RESPECTIVELY. +C +C IF THE CORE IS SMALL SCATTERING IS COMPUTED FOR THE SHELL ONLY + +c print*,'debut dmiess ',second(0.) + + IFLAG = 1 + IF ( R/RO .LT. 1.0E-06 ) IFLAG = 2 +C + IF ( JX .LE. IT ) GO TO 20 + WRITE( 6,7 ) + WRITE( 6,6 ) + STOP 30 + 20 RF = CMPLX( RFR, -RFI ) + RC = CMPLX( RE2,-TMAG2 ) + X = RO * WVNO + K1 = RC * WVNO + K2 = RF * WVNO + ZET=0.0 + K3 = CMPLX( WVNO, ZET ) + Z(1) = K2 * RO + Z(2) = K3 * RO + Z(3) = K1 * R + Z(4) = K2 * R + X1 = REAL( Z(1) ) + Y1 = AIMAG( Z(1) ) + X4 = REAL( Z(4) ) + Y4 = AIMAG( Z(4) ) +c X1 = REAL( Z(1) ) +c Y1 = AIMAG( Z(1) ) +c X4 = REAL( Z(4) ) +c Y4 = AIMAG( Z(4) ) + RRF = 1.0 / RF + RX = 1.0 / X + RRFX = RRF * RX + T(1) = ( X**2 ) * ( RFR**2 + RFI**2 ) + T(1) = SQRT( T(1) ) + NMX1 = 1.10 * T(1) + +C + IF ( NMX1 .LE. LL-1 ) GO TO 21 + WRITE(6,8) + PRINT*,'LL =',LL + STOP 32 + 21 NMX2 = T(1) + IF ( NMX1 .GT. 150 ) GO TO 22 + NMX1 = 150 + NMX2 = 135 +C + 22 ACAP( NMX1+1 ) = ( 0.0,0.0 ) + IF ( IFLAG .EQ. 2 ) GO TO 26 + DO 29 N = 1,3 + 29 W( N,NMX1+1 ) = ( 0.0,0.0 ) + 26 CONTINUE + DO 23 N = 1,NMX1 + NN = NMX1 - N + 1 + ACAP(NN) = (NN+1) * RRFX - 1.0 / ( (NN+1) * RRFX + ACAP(NN+1) ) + IF ( IFLAG .EQ. 2 ) GO TO 23 + DO 31 M = 1,3 + 31 W( M,NN ) = (NN+1) / Z(M+1) - + 1 1.0 / ( (NN+1) / Z(M+1) + W( M,NN+1 ) ) + 23 CONTINUE + DO 30 J = 1,JX + IF ( THETD(J) .LT. 0.0 ) THETD(J) = ABS( THETD(J) ) + IF ( THETD(J) .GT. 0.0 ) GO TO 24 + CSTHT(J) = 1.0 + SI2THT(J) = 0.0 + GO TO 30 + 24 IF ( THETD(J) .GE. 90.0 ) GO TO 25 + T(1) = ( 3.14159265359 * THETD(J) ) / 180.0 + CSTHT(J) = COS( T(1) ) + SI2THT(J) = 1.0 - CSTHT(J)**2 + GO TO 30 + 25 IF ( THETD(J) .GT. 90.0 ) GO TO 28 + CSTHT(J) = 0.0 + SI2THT(J) = 1.0 + GO TO 30 + 28 WRITE( 6,5 ) THETD(J) + WRITE( 6,6 ) + STOP 34 + 30 CONTINUE +C + DO 35 J = 1,JX + PI(1,J) = 0.0 + PI(2,J) = 1.0 + TAU(1,J) = 0.0 + TAU(2,J) = CSTHT(J) + 35 CONTINUE +C +C INITIALIZATION OF HOMOGENEOUS SPHERE + T(1) = COS(X) + T(2) = SIN(X) + WM1 = CMPLX( T(1),-T(2) ) + WFN(1) = CMPLX( T(2), T(1) ) + WFN(2) = RX * WFN(1) - WM1 + IF ( IFLAG .EQ. 2 ) GO TO 560 + N = 1 +C +C INITIALIZATION PROCEDURE FOR STRATIFIED SPHERE BEGINS HERE +C + SINX1 = SIN( X1 ) + SINX4 = SIN( X4 ) + COSX1 = COS( X1 ) + COSX4 = COS( X4 ) + EY1 = EXP( Y1 ) + E2Y1 = EY1 * EY1 + EY4 = EXP( Y4 ) + EY1MY4 = EXP( Y1 - Y4 ) + EY1PY4 = EY1 * EY4 + EY1MY4 = EXP( Y1 - Y4 ) + AA = SINX4 * ( EY1PY4 + EY1MY4 ) + BB = COSX4 * ( EY1PY4 - EY1MY4 ) + CC = SINX1 * ( E2Y1 + 1.0 ) + DD = COSX1 * ( E2Y1 - 1.0 ) + DENOM = 1.0 + E2Y1 * ( 4.0 * SINX1 * SINX1 - 2.0 + E2Y1 ) + REALP = ( AA * CC + BB * DD ) / DENOM + AMAGP = ( BB * CC - AA * DD ) / DENOM + DUMMY = CMPLX( REALP, AMAGP ) + AA = SINX4 * SINX4 - 0.5 + BB = COSX4 * SINX4 + P24H24 = 0.5 + CMPLX( AA,BB ) * EY4 * EY4 + AA = SINX1 * SINX4 - COSX1 * COSX4 + BB = SINX1 * COSX4 + COSX1 * SINX4 + CC = SINX1 * SINX4 + COSX1 * COSX4 + DD = -SINX1 * COSX4 + COSX1 * SINX4 + P24H21 = 0.5 * CMPLX( AA,BB ) * EY1 * EY4 + + 2 0.5 * CMPLX( CC,DD ) * EY1MY4 + DH4 = Z(4) / ( 1.0 + ( 0.0,1.0 ) * Z(4) ) - 1.0 / Z(4) + DH1 = Z(1) / ( 1.0 + ( 0.0,1.0 ) * Z(1) ) - 1.0 / Z(1) + DH2 = Z(2) / ( 1.0 + ( 0.0,1.0 ) * Z(2) ) - 1.0 / Z(2) + PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) + P24H24 = P24H24 / PSTORE + HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) + P24H21 = P24H21 / HSTORE + PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) + DUMMY = DUMMY * PSTORE + DUMSQ = DUMMY * DUMMY +C +C NOTE: THE DEFINITIONS OF U(I) IN THIS PROGRAM ARE NOT THE SAME AS +C +C USUB1 = U(1) USUB2 = U(5) +C USUB3 = U(7) USUB4 = DUMSQ +C USUB5 = U(2) USUB6 = U(3) +C USUB7 = U(6) USUB8 = U(4) +C RATIO OF SPHERICAL BESSEL FTN TO SPHERICAL HENKAL FTN = U(8) +C + U(1) = K3 * ACAP(N) - K2 * W(1,N) + U(2) = K3 * ACAP(N) - K2 * DH2 + U(3) = K2 * ACAP(N) - K3 * W(1,N) + U(4) = K2 * ACAP(N) - K3 * DH2 + U(5) = K1 * W(3,N) - K2 * W(2,N) + U(6) = K2 * W(3,N) - K1 * W(2,N) + U(7) = ( 0.0,-1.0 ) * ( DUMMY * P24H21 - P24H24 ) + U(8) = TA(3) / WFN(2) +C + FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / + 2 ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) + FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / + 2 ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) + GO TO 561 + 560 TC1 = ACAP(1) * RRF + RX + TC2 = ACAP(1) * RF + RX + FNA = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) + FNB = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) + 561 CONTINUE + FNAP = FNA + FNBP = FNB + T(1) = 1.50 +C +C FROM HERE TO THE STATMENT NUMBER 90, ELTRMX(I,J,K) HAS +C FOLLOWING MEANING: +C ELTRMX(1,J,K): REAL PART OF THE FIRST COMPLEX AMPLITUDE. +C ELTRMX(2,J,K): IMAGINARY PART OF THE FIRST COMPLEX AMPLITUDE. +C ELTRMX(3,J,K): REAL PART OF THE SECOND COMPLEX AMPLITUDE. +C ELTRMX(4,J,K): IMAGINARY PART OF THE SECOND COMPLEX AMPLITUDE. +C K = 1 : FOR THETD(J) AND K = 2 : FOR 180.0 - THETD(J) +C DEFINITION OF THE COMPLEX AMPLITUDE: VAN DE HULST,P.125. + TB(1) = T(1) * TB(1) + TB(2) = T(1) * TB(2) + TC(1) = T(1) * TC(1) + TC(2) = T(1) * TC(2) + DO 60 J = 1,JX + ELTRMX(1,J,1) = TB(1) * PI(2,J) + TC(1) * TAU(2,J) + ELTRMX(2,J,1) = TB(2) * PI(2,J) + TC(2) * TAU(2,J) + ELTRMX(3,J,1) = TC(1) * PI(2,J) + TB(1) * TAU(2,J) + ELTRMX(4,J,1) = TC(2) * PI(2,J) + TB(2) * TAU(2,J) + ELTRMX(1,J,2) = TB(1) * PI(2,J) - TC(1) * TAU(2,J) + ELTRMX(2,J,2) = TB(2) * PI(2,J) - TC(2) * TAU(2,J) + ELTRMX(3,J,2) = TC(1) * PI(2,J) - TB(1) * TAU(2,J) + ELTRMX(4,J,2) = TC(2) * PI(2,J) - TB(2) * TAU(2,J) + 60 CONTINUE +C + QEXT = 2.0 * ( TB(1) + TC(1)) + QSCAT = ( TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2 ) / 0.75 + CTBRQS = 0.0 + N = 2 + 65 T(1) = 2*N - 1 + T(2) = N - 1 + T(3) = 2*N + 1 + DO 70 J = 1,JX + PI(3,J) = ( T(1) * PI(2,J) * CSTHT(J) - N * PI(1,J) ) / T(2) + TAU(3,J) = CSTHT(J) * ( PI(3,J) - PI(1,J) ) - + 1 T(1) * SI2THT(J) * PI(2,J) + TAU(1,J) + 70 CONTINUE +C +C HERE SET UP HOMOGENEOUS SPHERE + WM1 = WFN(1) + WFN(1) = WFN(2) + WFN(2) = T(1) * RX * WFN(1) - WM1 + IF ( IFLAG .EQ. 2 ) GO TO 1000 +C +C HERE SET UP STRATIFIED SPHERE +C + DH2 = - N / Z(2) + 1.0 / ( N / Z(2) - DH2 ) + DH4 = - N / Z(4) + 1.0 / ( N / Z(4) - DH4 ) + DH1 = - N / Z(1) + 1.0 / ( N / Z(1) - DH1 ) + PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) + P24H24 = P24H24 / PSTORE + HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) + P24H21 = P24H21 / HSTORE + PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) + DUMMY = DUMMY * PSTORE + DUMSQ = DUMMY * DUMMY +C + U(1) = K3 * ACAP(N) - K2 * W(1,N) + U(2) = K3 * ACAP(N) - K2 * DH2 + U(3) = K2 * ACAP(N) - K3 * W(1,N) + U(4) = K2 * ACAP(N) - K3 * DH2 + U(5) = K1 * W(3,N) - K2 * W(2,N) + U(6) = K2 * W(3,N) - K1 * W(2,N) + U(7) = ( 0.0,-1.0 ) * ( DUMMY * P24H21 - P24H24 ) + U(8) = TA(3) / WFN(2) +C + FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / + 2 ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) + FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / + 2 ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) +C + 1000 CONTINUE + TC1 = ACAP(N) * RRF + N * RX + TC2 = ACAP(N) * RF + N * RX + FN1 = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) + FN2 = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) + M = WVNO * R + IF ( N .LT. M ) GO TO 1002 + IF ( IFLAG .EQ. 2 ) GO TO 1001 +C!!!!!!!!!!!! WARNING MODIF PERSO +C IF ( ABS( ( FN1-FNA ) / FN1 ) .LT. 1.0E-09 .AND. +C 1 ABS( ( FN2-FNB ) / FN2 ) .LT . 1.0E-09 ) IFLAG = 2 + + IF ( ABS( ( FN1-FNA ) / FN1 ) .LT. 1.0E-4 .AND. + 1 ABS( ( FN2-FNB ) / FN2 ) .LT . 1.0E-4 ) IFLAG = 2 + IF ( IFLAG .EQ. 1 ) GO TO 1002 + 1001 FNA = FN1 + FNB = FN2 + 1002 CONTINUE + T(5) = N + T(4) = T(1) / ( T(5) * T(2) ) + T(2) = ( T(2) * ( T(5) + 1.0 ) ) / T(5) +C + CTBRQS = CTBRQS + T(2) * ( TD(1) * TB(1) + TD(2) * TB(2) + + 1 TE(1) * TC(1) + TE(2) * TC(2) ) + 2 + T(4) * ( TD(1) * TE(1) + TD(2) * TE(2) ) + QEXT = QEXT + T(3) * ( TB(1) + TC(1) ) + T(4) = TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2 + QSCAT = QSCAT + T(3) * T(4) + T(2) = N * (N+1) + T(1) = T(3) / T(2) + K = (N/2)*2 + DO 80 J = 1,JX + ELTRMX(1,J,1) = ELTRMX(1,J,1)+T(1)*(TB(1)*PI(3,J)+TC(1)*TAU(3,J)) + ELTRMX(2,J,1) = ELTRMX(2,J,1)+T(1)*(TB(2)*PI(3,J)+TC(2)*TAU(3,J)) + ELTRMX(3,J,1) = ELTRMX(3,J,1)+T(1)*(TC(1)*PI(3,J)+TB(1)*TAU(3,J)) + ELTRMX(4,J,1) = ELTRMX(4,J,1)+T(1)*(TC(2)*PI(3,J)+TB(2)*TAU(3,J)) + IF ( K .EQ. N ) GO TO 75 + ELTRMX(1,J,2) = ELTRMX(1,J,2)+T(1)*(TB(1)*PI(3,J)-TC(1)*TAU(3,J)) + ELTRMX(2,J,2) = ELTRMX(2,J,2)+T(1)*(TB(2)*PI(3,J)-TC(2)*TAU(3,J)) + ELTRMX(3,J,2) = ELTRMX(3,J,2)+T(1)*(TC(1)*PI(3,J)-TB(1)*TAU(3,J)) + ELTRMX(4,J,2) = ELTRMX(4,J,2)+T(1)*(TC(2)*PI(3,J)-TB(2)*TAU(3,J)) + GO TO 80 + 75 ELTRMX(1,J,2) =ELTRMX(1,J,2)+T(1)*(-TB(1)*PI(3,J)+TC(1)*TAU(3,J)) + ELTRMX(2,J,2) =ELTRMX(2,J,2)+T(1)*(-TB(2)*PI(3,J)+TC(2)*TAU(3,J)) + ELTRMX(3,J,2) =ELTRMX(3,J,2)+T(1)*(-TC(1)*PI(3,J)+TB(1)*TAU(3,J)) + ELTRMX(4,J,2) =ELTRMX(4,J,2)+T(1)*(-TC(2)*PI(3,J)+TB(2)*TAU(3,J)) + 80 CONTINUE +C +C!!!!!!!!!!!! WARNING MODIF PERSO +C IF ( T(4) .LT. 1.0E-14 ) GO TO 100 + IF ( T(4) .LT. 1.0E-4 ) GO TO 100 + N = N + 1 + DO 90 J = 1,JX + PI(1,J) = PI(2,J) + PI(2,J) = PI(3,J) + TAU(1,J) = TAU(2,J) + TAU(2,J) = TAU(3,J) + 90 CONTINUE + FNAP = FNA + FNBP = FNB +c print*,'NMX2 =',nmx2 + IF ( N .LE. NMX2 ) GO TO 65 + WRITE( 6,8 ) + STOP 36 + 100 DO 120 J = 1,JX + DO 120 K = 1,2 + DO 115 I= 1,4 + T(I) = ELTRMX(I,J,K) + 115 CONTINUE + ELTRMX(2,J,K) = T(1)**2 + T(2)**2 + ELTRMX(1,J,K) = T(3)**2 + T(4)**2 + ELTRMX(3,J,K) = T(1) * T(3) + T(2) * T(4) + ELTRMX(4,J,K) = T(2) * T(3) - T(4) * T(1) + 120 CONTINUE + T(1) = 2.0 * RX**2 + QEXT = QEXT * T(1) + QSCAT = QSCAT * T(1) + CTBRQS = 2.0 * CTBRQS * T(1) +C +c print*,'NMX1= ',nmx1,' LL=',ll +c print*,'fin dmiess ',second(0.) + RETURN +C + 5 FORMAT( 10X,' THE VALUE OF THE SCATTERING ANGLE IS GREATER THAN + 1 90.0 DEGREES. IT IS ', E15.4 ) + 6 FORMAT( // 10X, 'PLEASE READ COMMENTS.' // ) + 7 FORMAT( // 10X, 'THE VALUE OF THE ARGUMENT JX IS GREATER THAN IT') + 8 FORMAT( // 10X, 'THE UPPER LIMIT FOR ACAP IS NOT ENOUGH. SUGGEST + 1 GET DETAILED OUTPUT AND MODIFY SUBROUTINE' // ) +C + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/drag_noro.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/drag_noro.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/drag_noro.F (revision 1643) @@ -0,0 +1,167 @@ + +C SUBROUTINE DE PARAMETRISATION DES MONTAGNES D ECHELLE SOUS MAILLE + + SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,pgeop,pn2, + e pmea,pstd, psig, pgam, pthe,ppic,pval, + e kgwd,kdx,ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + use dimphy + IMPLICIT none + +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Object: Mountain drag interface. Made necessary because: +C 1. in the LMD-GCM Layers are from bottom to top, +C contrary to most European GCM. +c 2. the altitude above ground of each model layers +c needs to be known (variable zgeom) +c====================================================================== +c Explicit Arguments: +c ================== +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c dtime---input-R-Time-step (s) +c paprs---input-R-Pressure in semi layers (Pa) +c pplay---input-R-Pressure model-layers (Pa) +c pgeop---input-R-Geopotential model layers (reference to ground) +c pn2-----input-R-Brunt-Vaisala freq.^2 at 1/2 layers +c t-------input-R-temperature (K) +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. + +c pulow, pvlow -output-R: Low-level wind +c pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) +c +c d_t-----output-R: T increment +c d_u-----output-R: U increment +c d_v-----output-R: V increment +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c (iim+1)*(jjm+1) for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c +c zgeom-----R: Altitude (m) of layer above ground (from top to bottom) +c pt, pu, pv --R: t u v from top to bottom +c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) +c papmf: pressure at model layer (from top to bottom) +c papmh: pressure at model 1/2 layer (from top to bottom) +c +c====================================================================== + +#include "YOMCST.h" +#include "YOEGWD.h" + +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) + REAL pgeop(nlon,nlev),pn2(nlon,nlev) + REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c LOCAL VARIABLES: +c + REAL zgeom(klon,klev),zn2(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c INITIALIZE OUTPUT VARIABLES +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM) +C CALCULATE LAYERS HEIGHT ABOVE GROUND) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + + DO k = klev, 1, -1 + DO i = 1, klon + zgeom(i,k) = pgeop(i,klev-k+1)/RG + zn2(i,k) = pn2(i,klev-k+1) + ENDDO + ENDDO + +c CALL SSO DRAG ROUTINES +c + CALL orodrag(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, zn2, + . pt, pu, pv, + . pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C +C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES + + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + ENDDO + ENDDO +c + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/dsolver.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dsolver.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dsolver.F (revision 1643) @@ -0,0 +1,82 @@ + SUBROUTINE DSOLVER(NL,GAMA,CP,CM,CPM1,CMM1 + ,,E1,E2,E3,E4,BTOP,BSURF,RSF,XK1,XK2) +C VERSION OF SOLVER +c PARAMETER (NMAX=201) + PARAMETER (NMAX=401) + IMPLICIT REAL (A-H,O-Z) + DIMENSION GAMA(NL),CP(NL),CM(NL), + ,CPM1(NL),CMM1(NL),XK1(NL),XK2(NL) + ,,E1(NL),E2(NL),E3(NL),E4(NL) + DIMENSION AF(NMAX),BF(NMAX),CF(NMAX),DF(NMAX),XK(NMAX) +C********************************************************* +C* THIS SUBROUTINE SOLVES FOR THE COEFFICIENTS OF THE * +C* TWO STREAM SOLUTION FOR GENERAL BOUNDARY CONDITIONS * +C* NO ASSUMPTION OF THE DEPENDENCE ON OPTICAL DEPTH OF * +C* C-PLUS OR C-MINUS HAS BEEN MADE. * +C* NL = NUMBER OF LAYERS IN THE MODEL * +C* CP = C-PLUS EVALUATED AT TAO=0 (TOP) * +C* CM = C-MINUS EVALUATED AT TAO=0 (TOP) * +C* CPM1 = C-PLUS EVALUATED AT TAOSTAR (BOTTOM) * +C* CMM1 = C-MINUS EVALUATED AT TAOSTAR (BOTTOM) * +C* EP = EXP(LAMDA*DTAU) * +C* EM = 1/EP * +C* E1 = EP + GAMA *EM * +C* E2 = EP - GAMA *EM * +C* E3 = GAMA*EP + EM * +C* E4 = GAMA*EP - EM * +C* BTOP = THE DIFFUSE RADIATION INTO THE MODEL AT TOP * +C* BSURF = THE DIFFUSE RADIATION INTO THE MODEL AT * +C* THE BOTTOM: INCLUDES EMMISION AND REFLECTION * +C* OF THE UNATTENUATED PORTION OF THE DIRECT * +C* BEAM. BSTAR+RSF*FO*EXP(-TAOSTAR/U0) * +C* RSF = REFLECTIVITY OF THE SURFACE * +C* XK1 = COEFFICIENT OF THE POSITIVE EXP TERM * +C* XK2 = COEFFICIENT OF THE NEGATIVE EXP TERM * +C********************************************************* + L=2*NL +C************MIXED COEFFICENTS********** +C* THIS VERSION AVOIDS SINGULARITIES ASSOC. +C* WIRH W0=0 BY SOLVING FOR XK1+XK2, AND XK1-XK2. + AF(1)=0.0 + BF(1)=GAMA(1)+1. + CF(1)=GAMA(1)-1. + DF(1)=BTOP-CMM1(1) + N=0 + LM2=L-2 +C* EVEN TERMS + DO 10 I=2,LM2,2 + N=N+1 + AF(I)=(E1(N)+E3(N))*(GAMA(N+1)-1.) + BF(I)=(E2(N)+E4(N))*(GAMA(N+1)-1.) + CF(I)=2.*(1.-GAMA(N+1)**2) + DF(I)=(GAMA(N+1)-1.) * (CPM1(N+1) - CP(N)) + & + (1.-GAMA(N+1))* (CM(N)-CMM1(N+1)) + 10 CONTINUE + N=0 + LM1=L-1 + DO 20 I=3,LM1,2 + N=N+1 + AF(I)=2.*(1.-GAMA(N)**2) + BF(I)=(E1(N)-E3(N))*(1.+GAMA(N+1)) + CF(I)=(E1(N)+E3(N))*(GAMA(N+1)-1.) + DF(I)=E3(N)*(CPM1(N+1) - CP(N)) + & + E1(N)*(CM(N) - CMM1(N+1)) + 20 CONTINUE + AF(L)=E1(NL)-RSF*E3(NL) + BF(L)=E2(NL)-RSF*E4(NL) + CF(L)=0.0 + DF(L)=BSURF-CP(NL)+RSF*CM(NL) + CALL DTRIDGL(L,AF,BF,CF,DF,XK) +C***UNMIX THE COEFFICIENTS**** + DO 28 N=1,NL + XK1(N)=XK(2*N-1)+XK(2*N) + XK2(N)=XK(2*N-1)-XK(2*N) +C NOW TEST TO SEE IF XK2 IS REALLY ZERO TO THE LIMIT OF THE +C MACHINE ACCURACY = 1 .E -30 +C XK2 IS THE COEFFICEINT OF THE GROWING EXPONENTIAL AND MUST +C BE TREATED CAREFULLY + IF (XK2(N) .EQ. 0.0) GO TO 28 + IF (ABS (XK2(N)/XK(2*N-1)) .LT. 1.E-30) XK2(N)=0.0 + 28 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/dtridgl.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dtridgl.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dtridgl.F (revision 1643) @@ -0,0 +1,29 @@ + SUBROUTINE DTRIDGL(L,AF,BF,CF,DF,XK) +C DOUBLE PRESCISION VERSION OF TRIDGL +c PARAMETER (NMAX=201) + PARAMETER (NMAX=401) + IMPLICIT REAL (A-H,O-Z) + DIMENSION AF(L),BF(L),CF(L),DF(L),XK(L) + DIMENSION AS(NMAX),DS(NMAX) +C* THIS SUBROUTINE SOLVES A SYSTEM OF TRIDIAGIONAL MATRIX +C* EQUATIONS. THE FORM OF THE EQUATIONS ARE: +C* A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = D(I) +C* WHERE I=1,L LESS THAN 103. +C* ..............REVIEWED -CP........ + AS(L) = AF(L)/BF(L) + DS(L) = DF(L)/BF(L) + DO 10 I=2,L + X=1./(BF(L+1-I) - CF(L+1-I)*AS(L+2-I)) + AS(L+1-I)=AF(L+1-I)*X + DS(L+1-I)=(DF(L+1-I)-CF(L+1-I)*DS(L+2-I))*X + 10 CONTINUE + XK(1)=DS(1) + DO 20 I=2,L + XKB=XK(I-1) + XK(I)=DS(I)-AS(I)*XKB + 20 CONTINUE + 910 FORMAT(/,8X,'AF(I)',7X,'BF(I)',7X,'CF(I)',7X,'DF(I)',7X, + * 'AS(I)',7X,'DS(I)',7X,'XK(I)',/) + 915 FORMAT((3X,7(1X,1PE11.4))) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/abort_gcm.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/abort_gcm.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/abort_gcm.F (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d/abort_gcm.F Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comconst_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comconst_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comconst_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/comconst_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comvert_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comvert_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/comvert_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/comvert_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/control_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/control_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/control_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/control_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/cpdet_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/cpdet_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/cpdet_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/cpdet_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/disvert_noterre.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/disvert_noterre.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/disvert_noterre.F (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/disvert_noterre.F Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/gr_dyn_fi.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/gr_dyn_fi.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/gr_dyn_fi.F (revision 1643) @@ -0,0 +1,1 @@ +link ../../dynphy_lonlat/gr_dyn_fi.F Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/infotrac.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/infotrac.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/infotrac.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/infotrac.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/inigeomphy_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/inigeomphy_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/inigeomphy_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dynphy_lonlat/inigeomphy_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/iniphysiq_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/iniphysiq_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/iniphysiq_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dynphy_lonlat/phytitan/iniphysiq_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/logic_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/logic_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/logic_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d/logic_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_const_mpi.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_const_mpi.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_const_mpi.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d/mod_const_mpi.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_interface_dyn_phys.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_interface_dyn_phys.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/mod_interface_dyn_phys.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dynphy_lonlat/mod_interface_dyn_phys.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/moyzon_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/moyzon_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/moyzon_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d/moyzon_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/paramet.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/paramet.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/paramet.h (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d_common/paramet.h Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/rcm1d.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/rcm1d.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/rcm1d.F (revision 1643) @@ -0,0 +1,481 @@ + PROGRAM rcm1d + + USE infotrac + use control_mod, only: planet_type, day_step +! use comgeomphy + USE phys_state_var_mod + USE comconst_mod, ONLY: cpp,t0_venus,nu_venus + use cpdet_mod, only: ini_cpdet + use moyzon_mod, only: plevmoy + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE iniphysiq_mod, ONLY: iniphysiq + USE mod_const_mpi, ONLY: comm_lmdz + USE physiq_mod, ONLY: physiq + IMPLICIT NONE + +c======================================================================= +c subject: +c -------- +c PROGRAM useful to run physical part of the venusian GCM in a 1D column +c +c Can be compiled with a command like (e.g. for 55 layers) +c "makelmdz -p titan -d 55 rcm1d" + +c It requires the files "rcm1d.def" "physiq.def" "traceur.def" +c and a file describing the sigma layers (e.g. "z2sig.def") +c +c author: Frederic Hourdin, R.Fournier,F.Forget (original Mars version) +c ------- Sebastien Lebonnois (Venus version) +c +c======================================================================= + +#include "dimensions.h" +#include "dimsoil.h" +#include "comcstfi.h" +#include "netcdf.inc" +#include "clesphys.h" +#include "iniprint.h" +#include "tabcontrol.h" + +c -------------------------------------------------------------- +c Declarations +c -------------------------------------------------------------- +c + INTEGER unit ! unite de lecture de "rcm1d.def" + INTEGER unitstart ! unite d'ecriture de "startphy.nc" + INTEGER nlayer,nlevel,nsoil,ndt + INTEGER ilayer,ilevel,isoil,idt,iq + LOGICAl firstcall,lastcall +c + INTEGER day0 ! date initial (sol ; =0 a Ls=0) + REAL day ! date durant le run + REAL time ! time (0 + area(1)=1.E+0 +c de meme ? + cufi(1)=1.E+0 + cvfi(1)=1.E+0 + +c Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid, +c e.g. for cell boundaries, which are meaningless in 1D; so pad these +c with '0.' when necessary + CALL iniphysiq(1,1,llm, + & 1,comm_lmdz, + & daysec,day0,dtphys, + & (/lati(1),0./),(/0./), + & (/0.,0./),(/long(1),0./), + & (/ (/area,0./),(/0.,0./) /), + & (/cufi,0.,0.,0./), + & (/cvfi,0./), + & rad,g,r,cpp,1) + + call ini_cpdet + +c le geopotentiel au sol est inutile en 1D car tout est controle +c par la pression de surface ---> + phisfi(1)=0.E+0 + +c Initialisation pour prendre en compte les vents en 1-D +c ------------------------------------------------------ + +c vent geostrophique + PRINT *,'composante vers l est du vent geostrophique (U) ?' + READ(unit,*) gru + PRINT *,'composante vers le nord du vent geostrophique (V) ?' + READ(unit,*) grv + +c Initialisation des vents au premier pas de temps + DO ilayer=1,nlayer + u(ilayer)=gru + v(ilayer)=grv + ENDDO + +c calcul des pressions et altitudes en utilisant les niveaux sigma +c ---------------------------------------------------------------- + +c Vertical Coordinates (hybrids) +c """""""""""""""""""" + CALL disvert_noterre + +c Calcul au milieu des couches : Vient de la version Mars +c WARNING : le choix de placer le milieu des couches au niveau de +c pression intermédiaire est arbitraire et pourrait etre modifié. +c C'est fait de la meme facon dans disvert + + DO l = 1, llm + aps(l) = 0.5 *( ap(l) +ap(l+1)) + bps(l) = 0.5 *( bp(l) +bp(l+1)) + ENDDO + + DO ilevel=1,nlevel + plev(ilevel)=ap(ilevel)+psurf*bp(ilevel) + ENDDO + allocate(plevmoy(nlevel)) + plevmoy(:)=plev(:) + + DO ilayer=1,nlayer + play(ilayer)=aps(ilayer)+psurf*bps(ilayer) + pk(ilayer) =cpp*(play(ilayer)/preff)**rcp +c write(120,*) ilayer,plev(ilayer),play(ilayer) + ENDDO +c write(120,*) nlevel,plev(nlevel) +c stop + + pks=cpp*(psurf/preff)**rcp + +c init des variables pour phyredem +c -------------------------------- + call phys_state_var_init + +c profil de temperature et altitude au premier appel +c -------------------------------------------------- + +c modif par rapport a Mars: +c on envoie dz/T=-log(play/psurf)*r/g dans profile + tmp1(0)=0.0 + tmp1(1)= -log(play(1)/psurf)*r/g + DO ilayer=2,nlayer + tmp1(ilayer)=-log(play(ilayer)/play(ilayer-1))*r/g + ENDDO + DO ilayer=0,nlayer + tmp2(ilayer)=plev(ilayer+1) + ENDDO + call profile(unit,nlayer+1,tmp1,tmp2,tmp3) + CLOSE(unit) + + print*," Pression Altitude Temperature" + ilayer=1 + ftsol(1)=tmp3(0) + temp(1)=tmp3(1) + zlay(1)=tmp3(1)*tmp1(1) + print*," 0",ftsol(1) + print*,ilayer,play(ilayer),zlay(ilayer),temp(ilayer) + DO ilayer=2,nlayer + temp(ilayer)=tmp3(ilayer) + zlay(ilayer)=zlay(ilayer-1)+tmp3(ilayer)*tmp1(ilayer) + print*,ilayer,play(ilayer),zlay(ilayer),temp(ilayer) + ENDDO + +c temperature du sous-sol +c ~~~~~~~~~~~~~~~~~~~~~~~ + DO isoil=1,nsoil + ftsoil(1,isoil)=ftsol(1) + ENDDO + +c Initialisation des traceurs +c --------------------------- + + DO iq=1,nqtot + DO ilayer=1,nlayer + q(ilayer,iq) = 0. + ENDDO + ENDDO + +c Initialisation des parametres d'oro +c ----------------------------------- + + zmea(1) = 0. + zstd(1) = 0. + zsig(1) = 0. + zgam(1) = 0. + zthe(1) = 0. + zpic(1) = 0. + zval(1) = 0. + +c Initialisation Ls +c ------------------ + zls=0. + print*,'Ls=',zls*180./pi + +c Initialisation albedo +c ---------------------- + + falbe(1)=0.3 + +c Ecriture de "startphy.nc" +c ------------------------- +c (Ce fichier sera aussitot relu au premier +c appel de "physiq", mais il est necessaire pour passer +c les variables purement physiques a "physiq"... + + solsw(1) = 0. + sollw(1) = 0. + fder(1) = 0. + radsol(1) = 0. + + radpas = NINT(1.*day_step/nbapp_rad) + soil_model = .true. + + call phyredem("startphy.nc") + +c deallocation des variables phyredem +c ----------------------------------- + call phys_state_var_end + +c======================================================================= +c BOUCLE TEMPORELLE DU MODELE 1D +c======================================================================= +c + firstcall=.true. + lastcall=.false. + + DO idt=1,ndt + IF (idt.eq.ndt) then + lastcall=.true. +c write(103,*) 'Ls=',zls*180./pi +c write(103,*) 'Lat=', lati(1) +c write(103,*) 'RunEnd - Atmos. Temp. File' +c write(103,*) 'RunEnd - Atmos. Temp. File' +c write(104,*) 'Ls=',zls*180./pi +c write(104,*) 'Lat=', lati(1) +c write(104,*) 'RunEnd - Atmos. Temp. File' + ENDIF + +c calcul du geopotentiel +c ~~~~~~~~~~~~~~~~~~~~~ +! ADAPTATION GCM POUR CP(T) + DO ilayer=1,nlayer + s(ilayer)=(play(ilayer)/psurf)**rcp + ENDDO + phi(1)=cpp*temp(1)*(1.E+0-s(1)) + DO ilayer=2,nlayer + phi(ilayer)=phi(ilayer-1)+ + & cpp*(temp(ilayer-1)/s(ilayer-1)+temp(ilayer)/s(ilayer))*0.5 + & *(s(ilayer-1)-s(ilayer)) + + ENDDO + +c appel de la physique +c -------------------- + + CALL physiq (1,llm,nqtot, + , firstcall,lastcall, + , day,time,dtphys, + , plev,play,pk,phi,phisfi, + , presnivs, + , u,v,temp,q, + , w, +C - sorties + s du,dv,dtemp,dq,dpsurf) + +c print*,"DT APRES PHYSIQ=",day,time +c print*,dtemp +c print*,temp +c print*," " +c stop + +c evolution du vent : modele 1D +c ----------------------------- + +c la physique calcule les derivees temporelles de u et v. +c Pas de coriolis + DO ilayer=1,nlayer + du(ilayer)=du(ilayer)+ (gru-u(ilayer))/1.e4 + dv(ilayer)=dv(ilayer)+ (grv-v(ilayer))/1.e4 + ENDDO +c +c Calcul du temps au pas de temps suivant +c --------------------------------------- + firstcall=.false. + time=time+dtphys/daysec + IF (time.gt.1.E+0) then + time=time-1.E+0 + day=day+1 + ENDIF + +c calcul des vitesses et temperature au pas de temps suivant +c ---------------------------------------------------------- + + DO ilayer=1,nlayer + u(ilayer)=u(ilayer)+dtphys*du(ilayer) + v(ilayer)=v(ilayer)+dtphys*dv(ilayer) + temp(ilayer)=temp(ilayer)+dtphys*dtemp(ilayer) + ENDDO + +c calcul des pressions au pas de temps suivant +c ---------------------------------------------------------- + + psurf=psurf+dtphys*dpsurf(1) ! evolution de la pression de surface + DO ilevel=1,nlevel + plev(ilevel)=ap(ilevel)+psurf*bp(ilevel) + ENDDO + DO ilayer=1,nlayer + play(ilayer)=aps(ilayer)+psurf*bps(ilayer) + ENDDO + + ENDDO ! fin de la boucle temporelle + +c ======================================================== +c GESTION DES SORTIE +c ======================================================== + + print*,"Temperature finale:" + print*,temp + +c stabilite + DO ilayer=1,nlayer + zlay(ilayer) = phi(ilayer)/g/1000. !en km + ENDDO + DO ilayer=2,nlayer + tmp1(ilayer) = + . (temp(ilayer)-temp(ilayer-1))/(zlay(ilayer)-zlay(ilayer-1)) + . + 1000.*g/cpp + ENDDO + + OPEN(11,file='profile.new') + DO ilayer=1,nlayer + write (11,*) zlay(ilayer),temp(ilayer),tmp1(ilayer) + ENDDO + +c ======================================================== + END + +c*********************************************************************** +c*********************************************************************** + +!#include "../dyn3d_common/disvert_noterre.F" +!#include "../dyn3d/abort_gcm.F" Index: trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/temps_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/temps_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/dyn1d/temps_mod.F90 (revision 1643) @@ -0,0 +1,1 @@ +link ../../dyn3d/temps_mod.F90 Index: trunk/LMDZ.TITAN.old/libf/phytitan/effg.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/effg.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/effg.F (revision 1643) @@ -0,0 +1,14 @@ + FUNCTION EFFG(Z) +#include "YOMCST.h" +! RA en m, Z en m... + +! Quand on prendra atmosphere epaisse dans dynamique +! (et dans physique, attention a clmain et autres...) + + EFFG = RG * (RA/(RA + Z ) )**2 + +! Pour l'instant: +! EFFG = RG + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/fi10.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/fi10.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/fi10.F (revision 1643) @@ -0,0 +1,5 @@ + FUNCTION FI10(X) + IMPLICIT REAL (A-H,O-Z) + FI10=.353/X+3.154000-.3060*X+.1410*X*X-2.887E-3*X**3 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/fi8.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/fi8.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/fi8.F (revision 1643) @@ -0,0 +1,5 @@ + FUNCTION FI8(X) + IMPLICIT REAL (A-H,O-Z) + FI8=.3737/X+3.718903-.1908*X+.1617*X*X-3.633E-3*X**3 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gamfcn.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gamfcn.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gamfcn.F (revision 1643) @@ -0,0 +1,86 @@ + FUNCTION GAMFCN(W,T,TAU1,TAU2) + IMPLICIT REAL (A-H,O-Z) +C +C COMPUTES THE LINE SHAPE FOR PRESSURE-INDUCED H2-H2 AND H2-HE +C TRANSITIONS, FROM THE SEMI-EMIRICAL FORMULAE OF BIRNBAUM ET AL. +C SEE EG., GEORGE BIRNBAUM AND E. RICHARD COHEN, CANADIAN JOURNAL +C OF PHYSICS, VOL. 54, 593 (1976). +C NOTE THAT "GAMFCN" IS A POOR NAME FOR THIS ROUTINE; THE GAMMA +C OF BIRNBAUM AND COHEN IS NOT THE USUAL "GAMMA FUNCTION". +C + save hk,pi,tau10,tau20 + DATA HK/7.638315E-12/,PI/3.141593/,TAU10/0.0/,TAU20/0.0/ + logical first + data first/.true./ + save first + +C NOTE: HK = 1.05450E-27 / 1.38054E-16 +C +C*********************************************************************** + save tau12,z2,hbh + + if (first) + s print*,'WARNING!!! ON rajoute des valeurs a 0.', + s 'Est-ce bien raisonable... dans GAMFCN' + first=.false. + IF (TAU1 .NE. TAU10) GO TO 10 + IF (TAU2 .EQ. TAU20) GO TO 20 + 10 TAU12 = TAU1 * TAU1 + TAU22 = TAU2 * TAU2 + HBH = 0.5 * HK / T + Z2 = SQRT(TAU22 + HBH**2) / TAU1 + TAU10 = TAU1 + TAU20 = TAU2 + 20 WSQR = W * W + Z = SQRT(1.0+WSQR*TAU12) * Z2 + IF (Z .LE. 1.0) GO TO 50 +C COMPUTE K1 BESSEL FUNCTION USING POLYNOMIAL APPROXIMATION + A = 1.0 / Z + BK1 = 1.253314 + .4699927*A + B = A * A + BK1 = BK1 - .1468583*B + B = B * A + BK1 = BK1 + .1280427*B + B = B * A + BK1 = BK1 - .1736432*B + B = B * A + BK1 = BK1 + .2847618*B + B = B * A + BK1 = BK1 - .4594342*B + B = B * A + BK1 = BK1 + .6283381*B + B = B * A + BK1 = BK1 - .6632295*B + B = B * A + BK1 = BK1 + .5050239*B + B = B * A + BK1 = BK1 - .2581304*B + B = B * A + BK1 = BK1 + .7880001E-01*B + B = B * A + BK1 = BK1 - .1082418E-01*B + BK1 = EXP(-Z) * BK1 * SQRT(A) + GO TO 100 +C COMPUTE K1 BESSEL FUNCTION USING SERIES EXPANSION + 50 A = 0.5 * Z + B = .5772157 + LOG(A) + C = A * A + BK1 = 1.0/Z + A*(B-0.5) + A = A * C + BK1 = BK1 + A*.2500000E+00*(0.5+(B-1.500000)*2.0) + A = A * C + BK1 = BK1 + A*.2777777E-01*(0.5+(B-1.833333)*3.0) + A = A * C + BK1 = BK1 + A*.1736110E-02*(0.5+(B-2.083333)*4.0) + A = A * C + BK1 = BK1 + A*.6944439E-04*(0.5+(B-2.283333)*5.0) + A = A * C + BK1 = BK1 + A*.1929009E-05*(0.5+(B-2.449999)*6.0) + A = A * C + BK1 = BK1 + A*.3936752E-07*(0.5+(B-2.592855)*7.0) + A = A * C + BK1 = BK1 + A*.6151173E-09*(0.5+(B-2.717855)*8.0) + 100 CONTINUE + GAMFCN = TAU1/PI * EXP(TAU2/TAU1+HBH*W) * Z*BK1 / (1.0+WSQR*TAU12) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gammb.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gammb.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gammb.F (revision 1643) @@ -0,0 +1,26 @@ + FUNCTION GAMMB(W,T,TAU1,TAU2) + IMPLICIT REAL (A-H,O-Z) + DATA HK/7.638967E-12/,PI/3.141592654/ +cfix ,TAU10/0./,TAU20/0./ 367. +C NOTE. HK = 1.05459e-27/1.38054e-16 +cfix IF (TAU1.NE.TAU10) GO TO 10 +cfix IF (TAU2.EQ.TAU20) GO TO 20 +cfix 10 CONTINUE + TAU12=TAU1*TAU1 + TAU22=TAU2*TAU2 + HBH = 0.5*HK/T + Z2=SQRT ( TAU22 + HBH**2) / TAU1 +cfix TAU10 = TAU1 +cfix TAU20=TAU2 +cfix 20 CONTINUE + WSQR=W*W + Z = SQRT (1.+ WSQR*TAU12) * Z2 +C COMPUTE THE MODIFIED BESSEL FUNCTION OF THE SECOND KIND (K1) +C USING AN UNPUBLISHED APPROXIMATION GIVEN BY COHEN. + F=1.5707963*(Z+0.5616)/(Z+0.4619) + BK1=SQRT(1.+Z*F) + BK1=BK1*EXP(-Z) + GAMMA=TAU1/PI*EXP(TAU2/TAU1+HBH*W)*BK1 / (1.+WSQR*TAU12) + GAMMB=GAMMA + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gas2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gas2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gas2.F (revision 1643) @@ -0,0 +1,115 @@ + SUBROUTINE GAS2(J,K,T,P,U,TAUGAS) +#include "dimensions.h" + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + COMMON /STRAT2/ HCN(NLAYER) + DIMENSION A(18),A1(18),A2(18),B(18),B1(18),B2(18) + DIMENSION C(18),C1(18),C2(18) + DIMENSION AHCN(11),A1HCN(11),A2HCN(11),BHCN(11),B1HCN(11) + DIMENSION B2HCN(11),CHCN(11),C1HCN(11),C2HCN(11) + DATA P0/0.1/ + +C P0 IS THE REFERENCE PRESSURE USED IN FORMULA +C PRESSURE IS IN BARS!!! ??FLAG? +C U IS IN MOLECULES PER CM2 + + DATA a / + &-58.07850,-73.66951,-22.00411,-26.61158,-27.04048,-25.84024, + & 0.00000,-18.70291,-16.08370,-23.03309,-31.18288,-19.96538, + &-24.37518,-17.94444, 0.00000,-17.46335,-20.93769,-10.74428/ + DATA a1/ + & 31.24782, 45.09350, 3.53728, 7.34218, 7.09808, 5.35252, + & 0.00000, 1.58486, -2.62994, 2.88087, 11.38614, 0.33491, + & 3.36078, -3.94288, 0.00000, -1.57041, 0.28770,-10.54978/ + DATA a2/ + & -6.15763, -9.47812, -0.72611, -1.73805, -1.65804, -1.23760, + & 0.00000, -0.33713, 0.84310, -0.44196, -2.79135, 0.00277, + & -0.60197, 1.27842, 0.00000, 0.37686, 0.08828, 2.77701/ + DATA b/ + & 5.27820, 2.66675, 1.31741, -5.05287, 1.88008, 4.49298, + & 0.00000, -0.94667, 2.77477, 15.80634, 33.83065, -2.29512, + & 2.90790, 0.77265, 0.00000, -0.95471, 3.30490, 0.43886/ + DATA b1/ + & -4.00372, -1.49356, -0.80081, 5.86571, -0.95994, -3.38754, + & 0.00000, 1.24800, -1.75869,-13.07462,-29.97486, 2.67427, + & -1.73763, 0.87904, 0.00000, 1.35597, -2.09025, 1.40393/ + DATA b2/ + & 0.81995, 0.32331, 0.16170, -1.42280, 0.26043, 0.87377, + & 0.00000, -0.31593, 0.36935, 2.86686, 6.83669, -0.75690, + & 0.24220, -0.46079, 0.00000, -0.42681, 0.32905, -0.61443/ + DATA c/ + & -8.99733, 6.51736, -0.54907, -4.80457, 2.83010, -2.12019, + & 0.00000, -1.53211,-13.48286,-18.91273,-16.89597, -1.02362, + & 0.25710, -6.27612, 0.00000, -0.56746, 0.14651, -8.53711/ + DATA c1/ + & 8.43865, -6.62977, 0.48722, 4.43910, -3.21534, 1.92581, + & 0.00000, 1.33927, 12.54849, 17.74174, 14.03467, 0.84636, + & -0.30260, 5.98928, 0.00000, 0.40909, -0.17410, 8.13665/ + DATA c2/ + & -1.99052, 1.64435, -0.13150, -1.02683, 0.80781, -0.49989, + & 0.00000, -0.30569, -2.91842, -4.14473, -2.91521, -0.18050, + & 0.06981, -1.43493, 0.00000, -0.07578, 0.03729, -1.93800/ + + DATA ahcn/ + & -33.41732,-35.36144,-19.76105,-16.45201,-13.09335,-18.84868, + & 0.00000,-18.605, -13.479, -20.717, -17.126/ + DATA a1hcn/ + & 11.42543, 12.36695, 2.43240, -2.78746, -6.36678, -0.49211, + & 0.00000, 1.0009, -4.9550, 2.0424, -2.0131/ + DATA a2hcn/ + & -2.20538, -2.46746, -0.66486, 0.78681, 1.54548, -0.05627, + & 0.00000, -0.33381, 1.0814, -0.73052, 0.24167/ + DATA bhcn/ + & -1.14762, 0.90664, 1.02184, -0.33594, -3.11059, -2.64450, + & 0.00000, -0.66681, -5.9630, -1.7662, -1.6016/ + DATA b1hcn/ + & 2.24061, 0.49483, -0.80223, 1.42836, 4.46001, 4.38418, + & 0.00000, 0.88177, 6.7881, 2.8273, 2.6971/ + DATA b2hcn/ + & -0.69153, -0.23858, 0.21351, -0.45182, -1.19719, -1.21663, + & 0.00000, -0.20593, -1.6747, -0.70656, -0.62399/ + DATA chcn/ + & -0.41463, 5.42790, 1.78780, -0.84225, -3.68653, 4.96968, + & 0.00000, 0.46294, -5.4664, 3.1475, -2.2176/ + DATA c1hcn/ + & 0.35005, -5.78523, -2.04583, 0.78874, 2.98507, -6.43269, + & 0.00000, -0.69540, 5.1038, -4.0865, 1.5738/ + DATA c2hcn/ + & -0.08749, 1.48015, 0.54974, -0.19827, -0.60826, 1.84860, + & 0.00000, 0.19795, -1.1936, 1.1768, -0.30869/ + + IF (K .GT. 11) THEN + XKV = A(K) + A1(K)*LOG10(T) + A2(K)*LOG10(T)**2 + & + LOG10(P/P0)*(B(K) + B1(K)*LOG10(T) + B2(K)*LOG10(T)**2) + & + (C(K) + C1(K)*LOG10(T) + C2(K)*LOG10(T)**2) + & *LOG10(P/P0)**2 + XKV=10.**XKV +C CLIP OUT THE CLEAR INTERVALS. + IF (A(K) .EQ. 0.0) XKV=0.0 + TAUGAS=U*C2H6(J)*XKV + ELSE + XKV = A(K) + A1(K)*LOG10(T) + A2(K)*LOG10(T)**2 + & + LOG10(P/P0)*(B(K) + B1(K)*LOG10(T) + B2(K)*LOG10(T)**2) + & + (C(K) + C1(K)*LOG10(T) + C2(K)*LOG10(T)**2) + & *LOG10(P/P0)**2 + XKV=10.**XKV + IF (A(K) .EQ. 0.0) XKV=0.0 + TAUGAS=U*C2H2(J)*XKV + XKVhcn = Ahcn(K) + A1hcn(K)*LOG10(T) + A2hcn(K)*LOG10(T)**2 + &+ LOG10(P/P0)*(Bhcn(K) + B1hcn(K)*LOG10(T) + B2hcn(K)*LOG10(T)**2) + &+ (Chcn(K) + C1hcn(K)*LOG10(T) + C2hcn(K)*LOG10(T)**2) + & *LOG10(P/P0)**2 + XKVhcn=10.**XKVhcn + IF (Ahcn(K) .EQ. 0.0) XKVhcn=0.0 + TAUGAShcn=U*HCN(J)*XKVhcn + +c if(j.eq.25) then +c print*,'J=',j,' P=',P,' HCN=',HCN(J),taugashcn, +c &' C2H2=',C2H2(J),taugas,' K=',K +c endif + + taugas = taugas+taugashcn + + ENDIF + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gas2_nohcn.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gas2_nohcn.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gas2_nohcn.F (revision 1643) @@ -0,0 +1,58 @@ + SUBROUTINE GAS2_NOHCN(J,K,T,P,U,TAUGAS) +#include "dimensions.h" + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + DIMENSION A(18),A1(18),A2(18),B(18),B1(18),B2(18) + DIMENSION C(18),C1(18),C2(18) + DATA P0/0.1/ +C P0 IS THE REFERENCE PRESSURE USED IN FORMULA +C PRESSURE IS IN BARS!!! ??FLAG? +C U IS IN MOLECULES PER CM2 + DATA a / + &-58.07850,-73.66951,-22.00411,-26.61158,-27.04048,-25.84024, + & 0.00000,-18.70291,-16.08370,-23.03309,-31.18288,-19.96538, + &-24.37518,-17.94444, 0.00000,-17.46335,-20.93769,-10.74428/ + DATA a1/ + & 31.24782, 45.09350, 3.53728, 7.34218, 7.09808, 5.35252, + & 0.00000, 1.58486, -2.62994, 2.88087, 11.38614, 0.33491, + & 3.36078, -3.94288, 0.00000, -1.57041, 0.28770,-10.54978/ + DATA a2/ + & -6.15763, -9.47812, -0.72611, -1.73805, -1.65804, -1.23760, + & 0.00000, -0.33713, 0.84310, -0.44196, -2.79135, 0.00277, + & -0.60197, 1.27842, 0.00000, 0.37686, 0.08828, 2.77701/ + DATA b/ + & 5.27820, 2.66675, 1.31741, -5.05287, 1.88008, 4.49298, + & 0.00000, -0.94667, 2.77477, 15.80634, 33.83065, -2.29512, + & 2.90790, 0.77265, 0.00000, -0.95471, 3.30490, 0.43886/ + DATA b1/ + & -4.00372, -1.49356, -0.80081, 5.86571, -0.95994, -3.38754, + & 0.00000, 1.24800, -1.75869,-13.07462,-29.97486, 2.67427, + & -1.73763, 0.87904, 0.00000, 1.35597, -2.09025, 1.40393/ + DATA b2/ + & 0.81995, 0.32331, 0.16170, -1.42280, 0.26043, 0.87377, + & 0.00000, -0.31593, 0.36935, 2.86686, 6.83669, -0.75690, + & 0.24220, -0.46079, 0.00000, -0.42681, 0.32905, -0.61443/ + DATA c/ + & -8.99733, 6.51736, -0.54907, -4.80457, 2.83010, -2.12019, + & 0.00000, -1.53211,-13.48286,-18.91273,-16.89597, -1.02362, + & 0.25710, -6.27612, 0.00000, -0.56746, 0.14651, -8.53711/ + DATA c1/ + & 8.43865, -6.62977, 0.48722, 4.43910, -3.21534, 1.92581, + & 0.00000, 1.33927, 12.54849, 17.74174, 14.03467, 0.84636, + & -0.30260, 5.98928, 0.00000, 0.40909, -0.17410, 8.13665/ + DATA c2/ + & -1.99052, 1.64435, -0.13150, -1.02683, 0.80781, -0.49989, + & 0.00000, -0.30569, -2.91842, -4.14473, -2.91521, -0.18050, + & 0.06981, -1.43493, 0.00000, -0.07578, 0.03729, -1.93800/ + XKV = A(K) + A1(K)*LOG10(T) + A2(K)*LOG10(T)**2 + &+ LOG10(P/P0)*(B(K) + B1(K)*LOG10(T) + B2(K)*LOG10(T)**2) + &+ (C(K) + C1(K)*LOG10(T) + C2(K)*LOG10(T)**2) + & *LOG10(P/P0)**2 + GASMIX=C2H2(J) + IF (K .GT. 11) GASMIX=C2H6(J) + XKV=10.**XKV +C CLIP OUT THE CLEAR INTERVALS. + IF (A(K) .EQ. 0.0) XKV=0.0 + TAUGAS=U*GASMIX*XKV + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gasses.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gasses.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gasses.F (revision 1643) @@ -0,0 +1,50 @@ + SUBROUTINE GASSES(IPRINT) +C THIS SUBROUTINE SETS UP THE MASS MIXING RATIOS OF THE +C OPTICALLY ACTIVE GASES: CH4, C2H2, AND C2H6 + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: RGAS,RHOP,PI,SIGMA + include "dimensions.h" + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) +C* +C NOW CALCULATE THE LAYER AVERAGE GAS MIXING RATIOS. +C OF THE ABSORBING GAS IN UNITS OF GRAMS PER GRAM +C AND THE TOTAL LAYER COLUMN MASS GRAMS CM-2. + DO 159 J=1,NLAYER + EMU=(XMU(J+1)+XMU(J))*0.5 +c attention ici, Z en km doit etre passe en m + COLDEN(J)=RHOP*(PRESS(J+1)-PRESS(J))/EFFG(Z(J)*1000.) + GAS1(J)=(16./EMU)*AVERGE(CH4(J+1),CH4(J)) +159 CONTINUE +C WE NOW ALSO CALCULTE THE MASS MIXING RATIOS OF THE +C STRATOSPHERIC GASES USED IN THE IR WITHIN EACH LAYER. + J=1 + FC2H2=1.8E-6 ! NEW FROM ATHENA OLD= 2.E-6 + FC2H6=1.2E-5 ! NEW FORM ATHENA OLD= 2.E-5 + C2H2(J) = MIN(FC2H2,PC2H2(TEMP(J))/PRESS(J)) + C2H6(J) = MIN(FC2H6,PC2H6(TEMP(J))/PRESS(J)) + DO 101 J=2,NLAYER + C2H2(J) = MIN(FC2H2,PC2H2(TEMP(J))/PRESS(J),C2H2(J-1)) + C2H6(J) = MIN(FC2H6,PC2H6(TEMP(J))/PRESS(J),C2H6(J-1)) +101 CONTINUE +C NOW CONVERT TO MASS MIXING RATIO + DO 102 J=1,NLAYER + EMU=(XMU(J+1)+XMU(J))*0.5 + C2H2(J)=C2H2(J)*26.0/EMU + C2H6(J)=C2H6(J)*30.0/EMU +102 CONTINUE +C + IF (IPRINT .LT. 1) RETURN + WRITE (6,9) + 9 FORMAT(///' ALT CH4 C2H2 C2H6: MASS MIXING RATIOS') + DO 103 J=1,NLAYER + WRITE (6,*)Z(J),GAS1(J),C2H2(J),C2H6(J) +c WRITE (6,10)Z(J),GAS1(J),C2H2(J),C2H6(J) +103 CONTINUE + 10 FORMAT(1X,F6.2,1P3E9.1) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/getimes.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/getimes.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/getimes.F (revision 1643) @@ -0,0 +1,128 @@ +c========================================================== +c getimes.F +c========================================================== +c Pack de routines pour calculer des temps d'execution. +c +c UTILISATION : +c L'appel a la routine initimes() doit se faire en +c début de programme. +c Pour calculer le temps d'execution d'une portion de +c code il suffit de placer la routine begintime devant +c la portion et la routine endtime après la portion. +c +c L'argument tps de la routine endtime retourne le +c temps d'execution en seconde de la portion de code. +c========================================================== + +************************************************** +* routine begintime * +* Retourne dans la variable nb_ini, le nombre de* +* cycle au moment de l'appel a begintime. * +* * +* ARGUMENTS : * +* nb_ini (output) : nombre de cycle au lancement* +* de la routine. * +************************************************** + subroutine begintime(nb_ini) + integer nb_ini + CALL SYSTEM_CLOCK(COUNT=nb_ini) + return + end + + +************************************************** +* routine endtime * +* Retourne dans la variable tps, le temps entre * +* l'appel a begintime et endtime. * +* * +* ARGUMENTS : * +* nb_ini (input) : nombre de cycle au lancement * +* de la routine begintime * +* tps (output) : temps en secondes ecoules * +* entre begintime et endtime * +************************************************** + subroutine endtime(nb_ini,tps) + implicit none + integer nb_max,nb_sec + common/horloge/nb_max,nb_sec + integer nb_ini + integer nb_fin,tmp + real tps + CALL SYSTEM_CLOCK(COUNT=nb_fin) + tmp =nb_fin-nb_ini + if (nb_fin.lt.nb_ini) tmp=tmp+nb_max + tps = FLOAT(tmp)/ nb_sec + return + end + +************************************************** +* routine initimes * +* Initialise le compteur * +* Cette routine doit se positionnee en debut de * +* programme * +************************************************** + subroutine initimes() +#include "itemps.h" + integer nb_max,nb_sec + common/horloge/nb_max,nb_sec + CALL SYSTEM_CLOCK(COUNT_RATE=nb_sec, + & COUNT_MAX=nb_max) +* initialisation variables de stockage + ttdynt = 0. + ttadvtr = 0. + ttphys = 0. + ttmuphys = 0. + tthaze = 0. + ttcclds = 0. + ttsclds = 0. + ttrad = 0. + ttphytra = 0. + + return + end + + +************************************************** +* routine printimes * +* affiche des temps d'execution. * +* iout : sortie dans un fichier. * +* iout = 0 ---> sortie ecran * +* iout = 1 ---> sortie dans temps.out * +************************************************** + subroutine printimes(iout) +#include "itemps.h" + integer iunit + logical ok + ok = .true. + iunit = 9 + if (iout.eq.0) then + iunit = 6 + else + do while (ok) + iunit = iunit+1 + inquire(unit=iunit,OPENED=ok) + if (iunit.eq.100) exit + enddo + if (iunit.eq.100) then + print*,"Je n'ai pas trouve d'unite logique libre." + print*,"J'affiche les temps a l'ecran." + iunit = 6 + endif + endif + if (iunit.ne.6) open(iunit,file="tpsprog") + write(iunit,*) "#############################################" + write(iunit,*) "ttdynt :",ttdynt + write(iunit,*) " ttdyn :",ttdynt-ttphys + write(iunit,*) " ttadvtr :",ttdyntr + write(iunit,*) " ttphys :",ttphys + write(iunit,*) " ttrad :",tthaze + write(iunit,*) " ttphytra :",ttphytra + write(iunit,*) " ttmuphys :",ttmuphys + write(iunit,*) " tthaze :",tthaze + write(iunit,*) " ttcclds :",ttcclds + write(iunit,*) " ttsclds :",ttsclds + write(iunit,*) "#############################################" + if (iunit.ne.6) close(iunit) + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/getqcld.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/getqcld.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/getqcld.F90 (revision 1643) @@ -0,0 +1,108 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! SUBROUTINE getoptcld(WLN,RADIUS,Q_EXT,Q_SCT,Q_ABS,Q_BAR) +! +! Obtention des QEXT,Q_SCT,Q_ABS,Q_BAR pour une particule de rayon RADIUS a la longueur +! d'onde WLN . +! +! ARGUMENTS D'ENTREE : +! WLN : Longueur d'onde traitee (en metres !) +! RADIUS : Rayon de la particule (en metres !) +! +! ARGUMENT DE SORTIE : +! Q_EXT : section efficace d'extinction +! Q_SCT : section efficace de diffusion +! Q_ABS : section efficace d'absorption +! Q_BAR : Parametre d'asymetrie +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE getoptcld(WLN,RADIUS,Q_EXT,Q_SCT,Q_ABS,Q_BAR) + USE optcld + IMPLICIT NONE +! ------ INPUT + REAL ,INTENT(in) :: WLN,RADIUS +! ------ OUTPUT + REAL ,INTENT(out) :: Q_EXT,Q_SCT,Q_ABS,Q_BAR +! ------ LOCAL/COMMON + REAL :: tmp + REAL,EXTERNAL :: get_qopt + +! INTERPOLATION/EXTRAPOLATION de QEXT,QABS,QBAR et CALCUL de QSCT +! notes : +! Comme les indices optiques des gaz sont peu variables en ldo et qu'on +! approxime la goutte comme etant composee d'hydrocarbone seulement, on +! a les relations suivantes : +! sigma(r,ldo) = sigma(r0,ldo*r0/r) * (r/r0)**2. +! gg(r,ldo) = gg(r0,ldo*r0/r) +! +! La routine get_qopt calcule sigma(r0,ldo*r0/r) ou gg(r0,ldo*r0/r) (selon les inputs) +! ====> il ne reste plus qu'a multiplier par (r/r0)**2. les sections efficaces :) +! +! ------------ +! QEXT (attention : ltq_ex car on travaille en log dans get_qopt) +! ------------ + tmp=get_qopt(radius,wln,A_ex,B_ex,fmin_ex,ltq_ex) + Q_EXT=tmp*(radius/r0cld)**2. +! ------------ +! QABS (attention : ltq_ab car on travaille en log dans get_qopt) +! ------------ + tmp=get_qopt(radius,wln,A_ab,B_ab,fmin_ab,ltq_ab) + Q_ABS=tmp*(radius/r0cld)**2. +! ------------ +! QSCT +! ------------ + Q_SCT=Q_EXT-Q_ABS +! ------------ +! QBAR (attention : ltq_gg car on travaille en log dans get_qopt) +! ------------ + tmp=get_qopt(radius,wln,A_gg,B_gg,fmin_gg,ltq_gg) + Q_BAR=tmp + + END SUBROUTINE getoptcld + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! REAL FUNCTION get_qopt(r,wln,A,B,fmin,) +! +! obtention d'une propriete optique pour une particule de taille r a la longueur d'onde wln +! a partir de la table tq. +! Les parametres tq,fmin,A et B definissent la propriete calculee (qext,qabs ou gg) +! +! ARGUMENTS D'ENTREE : +! r : Rayon de la particule (en metres !) +! wln : Longueur d'onde traitee (en metres !) +! tq : table de la propriete. +! fmin : parametre pour extrapolation (debut de table) +! A : parametre (coefficient directeur) pour extrapolation (fin de table) +! B : parametre (ordonnee a l'origine) pour extrapolation (fin de table) +! +! VALEUR DE RETOUR : +! Propriete optique recherchee a wln pour une taille r. +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + REAL FUNCTION get_qopt(r,wln,A,B,fmin,tq) + USE optcld + IMPLICIT NONE +! ------ INPUT + REAL ,INTENT(in) :: r,wln,A,B,fmin,tq(npts) +! ------ LOCAL + REAL :: wln_t,val + INTEGER :: ind,iver + +! initialisation generale + iver = 0 + val = 0. + wln_t = wln * (r0cld/r) + +! Recherche du point le plus proche dans la table + CALL locate(tq_wln,npts,wln_t,ind) + +! Interpolation/extrapolation selon l'indice. + IF (ind.le.0) THEN + val = fmin + ELSEIF(ind.ge.npts) THEN + CALL extrapolemoi(wln_t,A,B,val,.true.) + ELSE + CALL interpolemoi(ind,wln_t,ltq_wln,tq,npts,val,iver,.true.) + ENDIF + get_qopt=val + + END FUNCTION get_qopt + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/gfluxv.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gfluxv.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gfluxv.F (revision 1643) @@ -0,0 +1,218 @@ + SUBROUTINE GFLUXV(NTODO,WAVEN,DTDEL,TDEL,WDEL,CDEL + & , F0PI,RSF,BTOP,BSURF,FP,FM,FMIDP,FMIDM,IPRINT) +c PARAMETER (NL=101) + USE TGMDAT_MOD, ONLY: UBARI,UBARV,UBAR0 + IMPLICIT NONE + INTEGER IPRINT,I,J,K,IDELTA,NAYER,NL,NTODO + PARAMETER (NL=401) +C ??FLAG? THIS VALUE (101) MUST BE .GE. NTODO +C* THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITONS +C FOR THE VISIBLE FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT +C THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS +C MEASURED FROM THE TOP OF EACH LAEYER. (DTAU) TOP OF EACH LAYER HAS +C OPTICAL DEPTH TAU(N).IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N +C HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES +C FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES. +C THIS SUBROUTINE DIFFERS FROM ITS IR CONTERPART IN THAT HERE WE SOLVE FOR +C THE FLUXES DIRECTLY USING THE GENERALIZED NOTATION OF MEADOR AND WEAVOR +C J.A.S., 37, 630-642, 1980. + REAL B81,B82,R81 + REAL AP,AM,F0PI,DENOM,CMMID,TAUMID,RSF,BTOP + REAL EM,EP,PI,WAVEN,CPMID,BSURF,G4 +C THIS NEXT ROW OF VARIABLES ARE THOSE ACTUALLY USED IN THE +C ROUTINE + REAL W0(NL), COSBAR(NL),DTAU(NL),TAU(NL) + REAL wdel(ntodo-1),cdel(ntodo-1),dtdel(ntodo-1) + REAL tdel(ntodo),fm(ntodo),fp(ntodo) + REAL fmidm(ntodo),fmidp(ntodo) + REAL ALPHA(NL),LAMDA(NL),XK1(NL),XK2(NL) + REAL G1(NL),G2(NL),G3(NL) + REAL GAMA(NL),CP(NL),CM(NL),CPM1(NL),CMM1(NL) + &,E1(NL),E2(NL),E3(NL),E4(NL),EXPTRM(NL) + DATA PI/3.14159265358979323846/ + DATA IDELTA/1/ + NAYER=NTODO-1 + 505 CONTINUE +C TURN ON THE DELTA-FUNCTION IF REQUIRED HERE +c PRINT*,' UBAR0 ',UBARI,UBARV,UBAR0 + + IF (IDELTA .EQ. 0) THEN + DO 101 J=1,NAYER + W0(J)=WDEL(J) + COSBAR(J)=CDEL(J) + DTAU(J)=DTDEL(J) + TAU(J)=TDEL(J) +101 CONTINUE + TAU(NTODO)=TDEL(NTODO) + ELSE +C FOR THE DELTA FUNCTION HERE... + TAU(1)=TDEL(1)*(1.-WDEL(1)*CDEL(1)**2) + DO 102 J=1,NAYER + W0(J)=WDEL(J)*(1.-CDEL(J)**2)/(1.-WDEL(J)*CDEL(J)**2) + COSBAR(J)=CDEL(J)/(1.+CDEL(J)) + DTAU(J)=DTDEL(J)*(1.-WDEL(J)*CDEL(J)**2) + TAU(J+1)=TAU(J)+DTAU(J) +c print*,'W0=',W0(J),' COSBAR=',COSBAR(J) +c print*,'DTAU=',DTAU(J),' TAU=',TAU(J) +c print*,'WDEL=',WDEL(J),' CDEL=',CDEL(J),' DTDEL=',DTDEL(J) +102 CONTINUE + ENDIF +C WE GO WITH THE HEMISPHERIC CONSTANT APPROACH +C AS DEFINED BY M&W - THIS IS THE WAY THE IR IS DONE + DO 20 J=1,NAYER + ALPHA(J)=SQRT( (1.-W0(J))/(1.-W0(J)*COSBAR(J)) ) +C THIS SET OF G'S IS FOR THE TWO STREAM HEMI-CONSTANT +C G1(J)=(1.-W0(J)*0.5*(1.+COSBAR(J)))/UBARV +C G2(J)=W0(J)*0.5*(1.-COSBAR(J))/UBARV +C G3(J)=0.5*(1.-COSBAR(J)) +C SET OF CONSTANTS DETERMINED BY DOM + G1(J)= (SQRT(3.)*0.5)*(2. - W0(J)*(1.+COSBAR(J))) + G2(J)= (SQRT(3.)*W0(J)*0.5)*(1.-COSBAR(J)) + G3(J)=0.5*(1.-SQRT(3.)*COSBAR(J)*UBAR0) + LAMDA(J)=SQRT(G1(J)**2 - G2(J)**2) + GAMA(J)=(G1(J)-LAMDA(J))/G2(J) + + 20 CONTINUE + DO 7 J=1,NAYER + G4=1.-G3(J) + DENOM=LAMDA(J)**2 - 1./UBAR0**2 +c print*,'G1(J)**2- G2(J)**2',G1(J)**2 - G2(J)**2 +c print*,'SQRT(G1(J)**2 - G2(J)**2)',SQRT(G1(J)**2 +c & - G2(J)**2) +c print*,'DENOM=',LAMDA(J)**2,1./UBAR0**2 +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH A IF STATEMENT + IF ( DENOM .EQ. 0.) THEN + PRINT*,UBAR0 + DENOM=1.E-4 + PRINT*,'G1(J)**2- G2(J)**2',G1(J)**2 - G2(J)**2 + PRINT*,'SQRT(G1(J)**2 - G2(J)**2)',SQRT(G1(J)**2 + & - G2(J)**2) + PRINT*,'DENOM=',LAMDA(J)**2,1./UBAR0**2 + WRITE (6,99) + 99 FORMAT (' DENOM ZERO; RESET # 1IN GFLUXV, W0=0?') + END IF + AM=F0PI*W0(J)*(G4 *(G1(J)+1./UBAR0) +G2(J)*G3(J) )/DENOM + AP=F0PI*W0(J)*(G3(J)*(G1(J)-1./UBAR0) +G2(J)*G4 )/DENOM +C* CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE TOP OF THE LAYER, THAT IS LOWER OPTICAL DEPTH TAU(J) + CPM1(J)=AP*EXP(-TAU(J)/UBAR0) + CMM1(J)=AM*EXP(-TAU(J)/UBAR0) +C* CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +C BOTTOM OF THE LAYER. THAT IS AT HIGHER OPTICAL DEPTH TAU(J+1) + CP(J)=AP*EXP(-TAU(J+1)/UBAR0) + CM(J)=AM*EXP(-TAU(J+1)/UBAR0) +c print*,'AM=',AM,' AP=',AP +c print*,'CPM1(J)=',CPM1(J),' CMM1(J)=',CMM1(J) +c print*,'CP(J)=',CP(J),' CM(J)=',CM(J) + 7 CONTINUE +C* +C* NOW CALCULATE THE EXPONENTIAL TERMS NEEDED +C* FOR THE TRIDIAGONAL ROTATED LAYERED METHOD +C* WARNING IF DTAU(J) IS GREATER THAN ABOUT 35 +C* WE CLIPP IT TO AVOID OVERFLOW. +C* EXP (TAU) - EXP(-TAU) WILL BE NONSENSE THIS IS +C* CORRECTED IN THE DSOLVER ROUTINE. ??FLAG? + DO 103 J=1,NAYER + EXPTRM(J)=35. + IF ( LAMDA(J)*DTAU(J) .LT. 35. ) EXPTRM(J)=LAMDA(J)*DTAU(J) +103 CONTINUE +C* NEED TO CLIPP THE EXPONENTIAL HERE. + DO 8 J=1,NAYER + EP=EXP(EXPTRM(J)) + EM=1.0/EP + E1(J)=EP+GAMA(J)*EM + E2(J)=EP-GAMA(J)*EM + E3(J)=GAMA(J)*EP+EM + E4(J)=GAMA(J)*EP-EM + 8 CONTINUE +C + B81=BTOP + B82=BSURF + R81=RSF + CALL DSOLVER(NAYER,GAMA,CP,CM,CPM1,CMM1 + & ,E1,E2,E3,E4,B81,B82,R81,XK1,XK2) +C +C EVALUATE THE NTODO FLUXES THROUGH THE NAYER LAYERS +C USE THE TOP (TAU=0) OPTICAL DEPTH EXPRESSIONS TO EVALUATE FP AND FM +C AT THE THE TOP OF EACH LAYER,J = LEVEL J + DO 46 J=1,NAYER + FP(J)= XK1(J) + GAMA(J)*XK2(J) + CPM1(J) + FM(J)=GAMA(J)*XK1(J) + XK2(J) + CMM1(J) + 46 CONTINUE +C USE EXPRESSION FOR BOTTOM FLUX TO GET THE FP AND FM AT NTODO + J=NAYER + EP=EXP(EXPTRM(J)) + EM=1.0/EP + FP(J+1)=XK1(J)*EP + GAMA(J)*XK2(J)*EM + CP(J) + FM(J+1)=XK1(J)*EP*GAMA(J) + XK2(J)*EM + CM(J) +C NOTE THAT WE HAVE SOLVED FOR THE FLUXES DIRECTLY AND NO +C FURTHER INTEGRATION IS NEEDED, THE UBARV TERM IS ABSORBED +C INTO THE DEFINITION OF G1 THU G4 +C UBARV = .5 IS HEMISPHERIC CONSTANT +C UBARV = SQRT(3) IS GAUSS QUADRATURE +C AND OTHER CASES AS PER MEADOR AND WEAVOR, JAS, 37, 630-643,1980. +C +C ADD THE DIRECT FLUX TERM TO THE DOWNWELLING RADIATION, LIOU 182 + DO 80 J=1,NTODO + FM(J)=FM(J)+UBAR0*F0PI*EXP(-TAU(J)/UBAR0) + 80 CONTINUE +C +C NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS. +C EXACLTY ANALOGOUS TO THE ABOVE COMPUTATION +C + DO 1982 J=1,NAYER + EP=EXP(0.5*EXPTRM(J)) + EM=1.0/EP + G4=1.-G3(J) + DENOM=LAMDA(J)**2 - 1./UBAR0**2 +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH A IF STATEMENT + IF ( DENOM .EQ. 0.) THEN + DENOM=1.E-4 + PRINT*,'G1(J)**2- G2(J)**2',G1(J)**2 - G2(J)**2 + PRINT*,'SQRT(G1(J)**2 - G2(J)**2)',SQRT(G1(J)**2 + & - G2(J)**2) + PRINT*,'DENOM=',LAMDA(J)**2,1./UBAR0**2 + WRITE (6,78) + 78 FORMAT (' DENOM ZERO; RESET # 2 IN GFLUXV, W0=0?') + END IF + AM=F0PI*W0(J)*(G4 *(G1(J)+1./UBAR0) +G2(J)*G3(J) )/DENOM + AP=F0PI*W0(J)*(G3(J)*(G1(J)-1./UBAR0) +G2(J)*G4 )/DENOM +C* CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE MIDDLE OF THE LAYER, THAT IS LOWER OPTICAL DEPTH TAU(J)+ + TAUMID= (TAU(J)+0.5*DTAU(J) ) + CPMID=AP*EXP(-TAUMID/UBAR0) + CMMID=AM*EXP(-TAUMID/UBAR0) + FMIDP(J)=XK1(J)*EP + GAMA(J)*XK2(J)*EM + CPMID + FMIDM(J)=XK1(J)*EP*GAMA(J) + XK2(J)*EM + CMMID +C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM + FMIDM(J)= FMIDM(J) +UBAR0*F0PI*EXP(-TAUMID/UBAR0) + 1982 CONTINUE +C ** NOW PRINTOUT IF NECESSARY + IF (IPRINT .LT. 9) RETURN + WRITE(6,601) F0PI,RSF,BTOP,BSURF + DO 120 J=1,NAYER + WRITE (6,301) TAU(J),FP(J),FM(J),DTAU(J),W0(J),COSBAR(J) + & ,ALPHA(J), LAMDA(J),G1(J),G2(J),G3(J) + 120 CONTINUE + J=NTODO + WRITE (6,301) TAU(J),FP(J),FM(J) + WRITE (6,602) + DO 130 J=1,NAYER + WRITE (6,301) CP(J),CM(J),E1(J),E2(J),E3(J),E4(J),CPM1(J) + & ,CMM1(J),GAMA(J) + 130 CONTINUE + 301 FORMAT(1X,1P13E10.3) + 602 FORMAT(' CP(J),CM(J),E1(J),E2(J),EM1(J),EM2(J),CPM1(J),CMM1(J)' + & ,',GAMA(J)') + 601 FORMAT(1X,'F0PI,RSF,BTOP,BSURF= ',1P4E10.3,/ + & ' TAU,FUP,FDOWN,DTAU(J),W0(J),COSBAR(J)' + & ,',ALPHA(J),LAMDA(J),G1,G2,G3') +C *******************************************************************012 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/gr_fi_ecrit.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gr_fi_ecrit.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gr_fi_ecrit.F90 (revision 1643) @@ -0,0 +1,24 @@ +SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit) + IMPLICIT none + ! + ! Tranformer une variable de la grille physique a + ! la grille d'ecriture + ! + ! WARNING: This only works on the full global grid + ! (ie for GCM in serial mode) + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield) + ! + INTEGER i, n, ig + ! + jjm = jjmp1 - 1 + DO n = 1, nfield + DO i=1,iim + ecrit(i,n) = fi(1,n) + ecrit(i+jjm*iim,n) = fi(nlon,n) + ENDDO + DO ig = 1, nlon - 2 + ecrit(iim+ig,n) = fi(1+ig,n) + ENDDO + ENDDO +END SUBROUTINE gr_fi_ecrit Index: trunk/LMDZ.TITAN.old/libf/phytitan/grid_noro.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/grid_noro.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/grid_noro.F (revision 1643) @@ -0,0 +1,487 @@ +! +! $Id: grid_noro.F 1442 2010-10-18 08:31:31Z jghattas $ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat + IMPLICIT none + +#include "YOMCST.h" + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar +c parametres lies au fichier d entree... A documenter... + integer iext + parameter(iext=216) + REAL xusn(imdep+2*iext),yusn(jmdep+2) + REAL zusn(imdep+2*iext,jmdep+2) + +c local var + real zdeltax,zdeltay,zlenx,zleny,xincr + real zbordnor,zbordsud,zbordest,zbordoue,weighx,weighy + real zllmmea,zllmstd,zllmsig,zllmgam,zllmpic,zllmval,zllmthe + real zminthe,xk,xl,xm,xp,xq,xw + real zmeanor,zmeasud,zstdnor,zstdsud,zsignor,zsigsud + real zweinor,zweisud,zpicnor,zpicsud,zvalnor,zvalsud + integer i,j,ii,jj + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(nbp_lon+1,nbp_lat),zxtzx(nbp_lon+1,nbp_lat) + REAL zytzy(nbp_lon+1,nbp_lat),zxtzy(nbp_lon+1,nbp_lat) + REAL weight(nbp_lon+1,nbp_lat) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(imdep+2*iext,jmdep+2) + REAL zytzyusn(imdep+2*iext,jmdep+2) + REAL zxtzyusn(imdep+2*iext,jmdep+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) + + REAL a(2200),b(2200),c(1100),d(1100) + +c pas defini puisque pas de physique dans newstart... + RPI=2.*ASIN(1.) + RA=2575000. + + print *,' parametres de l orographie a l echelle sous maille' + + zdeltay=2.*RPI/REAL(jmdep)*RA +c +c quelques tests de dimensions: +c +c + if(nbp_lon.ne.imar) STOP 'Problem dim. x' + if(nbp_lat-1.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imar+1.ne.nbp_lon+1.or.jmar.ne.nbp_lat)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jmdep + yusn(j+1)=ydata(j) + DO i=1,imdep + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(imdep-iext+i,j) + xusn(i)=xdata(imdep-iext+i)-2.*RPI + zusn(imdep+iext+i,j+1)=zdata(i,j) + xusn(imdep+iext+i)=xdata(i)+2.*RPI + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jmdep+2)=ydata(jmdep)+(ydata(jmdep)-ydata(jmdep-1)) + DO i=1,imdep/2+iext + zusn(i,1)=zusn(i+imdep/2,2) + zusn(i+imdep/2+iext,1)=zusn(i,2) + zusn(i,jmdep+2)=zusn(i+imdep/2,jmdep+1) + zusn(i+imdep/2+iext,jmdep+2)=zusn(i,jmdep+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jmdep+2 + DO i = 1, imdep+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jmdep+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, imdep+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=RPI/REAL(jmdep)*RA + xincr=RPI/2./REAL(jmdep) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jmdep+1 +c DO j = 3,jmdep + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*RA + zbordsud=(yusn(j)-d(jj)+xincr)*RA + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, imdep+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*RA*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*RA*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + CALL MVA9(zmea,nbp_lon+1,nbp_lat) + CALL MVA9(zstd,nbp_lon+1,nbp_lat) + CALL MVA9(zpic,nbp_lon+1,nbp_lat) + CALL MVA9(zval,nbp_lon+1,nbp_lat) + CALL MVA9(zxtzx,nbp_lon+1,nbp_lat) + CALL MVA9(zxtzy,nbp_lon+1,nbp_lat) + CALL MVA9(zytzy,nbp_lon+1,nbp_lat) + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: + zsig(ii,jj)=sqrt(xq) +c isotropy: + zgam(ii,jj)=xp/xq +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2. + zphi(ii,jj)=zmea(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj) + zpic(ii,jj)=zpic(ii,jj) + zval(ii,jj)=zval(ii,jj) + zstd(ii,jj)=zstd(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + REAL X(IMAR,JMAR),XF(IMAR,JMAR) + real WEIGHTpb(-1:1,-1:1) + + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/gwprofil.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gwprofil.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gwprofil.F (revision 1643) @@ -0,0 +1,220 @@ + subroutine gwprofil + * ( nlon, nlev + * , kgwd ,kdx , ktest + * , kkcrit, kkcrith, kcrit , kkenvh, kknu,kknu2 + * , paphm1, prho , pstab , ptfr , pvph , pri , ptau + * , pdmod , pnu , psig ,pgamma, pstd, ppic,pval) + +C**** *gwprofil* +C +C purpose. +C -------- +C +C** interface. +C ---------- +C from *gwdrag* +C +C explicit arguments : +C -------------------- +C ==== inputs === +C +C ==== outputs === +C +C implicit arguments : none +C -------------------- +C +C method: +C ------- +C the stress profile for gravity waves is computed as follows: +C it decreases linearly with heights from the ground +C to the low-level indicated by kkcrith, +C to simulates lee waves or +C low-level gravity wave breaking. +C above it is constant, except when the waves encounter a critical +C level (kcrit) or when they break. +C The stress is also uniformly distributed above the level +C ntop. +C + use dimphy + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOEGWD.h" + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + integer nlon,nlev,kgwd + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon) + * ,kdx(nlon),ktest(nlon) + * ,kkenvh(nlon),kknu(nlon),kknu2(nlon) +C + real paphm1(nlon,nlev+1), pstab(nlon,nlev+1), + * prho (nlon,nlev+1), pvph (nlon,nlev+1), + * pri (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1) + + real pdmod (nlon) , pnu (nlon) , psig(nlon), + * pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon) + +C----------------------------------------------------------------------- +C +C* 0.2 local arrays +C ------------ +C + integer jl,jk + real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt + + real zdz2 (klon,klev) , znorm(klon) , zoro(klon) + real ztau (klon,klev+1) +C +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C +C print *,' entree gwprofil' + 100 CONTINUE +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C + do 400 jl=kidia,kfdia + if(ktest(jl).eq.1)then + zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl) + ztau(jl,klev+1)=ptau(jl,klev+1) +c print *,jl,ptau(jl,klev+1) + ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1) + endif + 400 continue + +C + do 430 jk=klev+1,1,-1 +C +C +C* 4.1 constant shear stress until top of the +C low-level breaking/trapped layer + 410 CONTINUE +C + do 411 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.gt.kkcrith(jl)) then + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) + zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) + ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt* + c (ztau(jl,kkcrith(jl))-ztau(jl,klev+1)) + else + ptau(jl,jk)=ztau(jl,kkcrith(jl)) + endif + endif + 411 continue +C +C* 4.15 constant shear stress until the top of the +C low level flow layer. + 415 continue +C +C +C* 4.2 wave displacement at next level. +C + 420 continue +C + 430 continue + +C +C* 4.4 wave richardson number, new wave displacement +C* and stress: breaking evaluation and critical +C level +C + + do 440 jk=klev,1,-1 + + do 441 jl=kidia,kfdia + if(ktest(jl).eq.1)then + znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk) + zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl) + endif + 441 continue + + do 442 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.lt.kkcrith(jl)) then + if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then + ptau(jl,jk)=0.0 + else + zsqr=sqrt(pri(jl,jk)) + zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk) + zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2 + if(zriw.lt.grcrit) then +c print *,' breaking!!!',ptau(jl,jk),zsqr + zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit + zb=1./grcrit+2./zsqr + zalpha=0.5*(-zb+sqrt(zdel)) + zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk) + ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl) + endif + + ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1)) + + endif + endif + endif + 442 continue + 440 continue + +C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL + + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1)then + ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1) + ztau(jl,ntop)=ptau(jl,ntop) + endif + 530 continue + + do 531 jk=1,klev + + do 532 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.gt.kkcrith(jl)-1)then + + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1 ) + zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1 ) + ptau(jl,jk)=ztau(jl,klev+1 ) + + . (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1 ) )* + . zdelp/zdelpt + + endif + endif + + 532 continue + +C REORGANISATION AT THE MODEL TOP.... + + do 533 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.lt.ntop)then + + zdelp =paphm1(jl,ntop) + zdelpt=paphm1(jl,jk) + ptau(jl,jk)=ztau(jl,ntop)*zdelpt/zdelp +c ptau(jl,jk)=ztau(jl,ntop) + + endif + + endif + + 533 continue + + + 531 continue + + + 123 format(i4,1x,20(f6.3,1x)) + + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/gwstress.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/gwstress.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/gwstress.F (revision 1643) @@ -0,0 +1,143 @@ + SUBROUTINE gwstress + * ( nlon , nlev + * , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh + * , kknu + * , prho , pstab , pvph , pstd, psig + * , pmea , ppic , pval , ptfr , ptau + * , pgeom1 , pgamma , pd1 , pd2 , pdmod , pnu ) +c +c**** *gwstress* +c +c purpose. +c -------- +c Compute the surface stress due to Gravity Waves, according +c to the Phillips (1979) theory of 3-D flow above +c anisotropic elliptic ridges. + +C The stress is reduced two account for cut-off flow over +C hill. The flow only see that part of the ridge located +c above the blocked layer (see zeff). +c +c** interface. +c ---------- +c call *gwstress* from *gwdrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c LOTT and MILLER (1997) & LOTT (1999) +c +c author. +c ------- +c +c modifications. +c -------------- +c f. lott put the new gwd on ifs 22/11/93 +c +c----------------------------------------------------------------------- + use dimphy + implicit none + +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon) +c + real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1), + * pvph(nlon,nlev+1),ptfr(nlon), + * pgeom1(nlon,nlev),pstd(nlon) +c + real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon) + real pmea(nlon),ppic(nlon),pval(nlon) + real pdmod(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c zeff--real: effective height seen by the flow when there is blocking + + integer jl + real zeff +c +c----------------------------------------------------------------------- +c +c* 0.3 functions +c --------- +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in gwstress' + 100 continue +c +c* 3.1 gravity wave stress. +c + 300 continue +c +c + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + +c effective mountain height above the blocked flow + + zeff=ppic(jl)-pval(jl) + if(kkenvh(jl).lt.klev)then + zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1)) + c ,zeff) + endif + + + ptau(jl,klev+1)=gkdrag*prho(jl,klev+1) + * *psig(jl)*pdmod(jl)/4./pstd(jl) + * *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1)) + * *zeff**2 + + +c too small value of stress or low level flow include critical level +c or low level flow: gravity wave stress nul. + +c lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl)) +c * .or.(pvph(jl,klev+1).lt.gvcrit) +c if(lo) ptau(jl,klev+1)=0.0 + +c print *,jl,ptau(jl,klev+1) + + else + + ptau(jl,klev+1)=0.0 + + endif + + 301 continue + +c write(21)(ptau(jl,klev+1),jl=kidia,kfdia) + + return + end + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/h2ener.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/h2ener.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/h2ener.F (revision 1643) @@ -0,0 +1,36 @@ + FUNCTION H2ENER(V,J) +C H2ENER SUBROUTINE OF THE INV PROGRAM. COMPUTES THE ENERGY +C (IN CM-1) OF A VIBRATION-ROTATION STATE OF A HYDROGEN MOLECULE. +C THE VIBRATION QUANTUM NUMBER IS V, AND THE QUANTUM NUMBER FOR +C THE RIGID BODY ANGULAR MOMENTUM IS J (A REAL*4 QUANTITY). +C THE FIRST LINE OF THE FORMULA FOR E IS THE CONTRIBUTION FROM +C PURE VIBRATION, INCLUDING ANHARMONIC TERMS. THE OTHER LINES +C ACCOUNT FOR COUPLED VIBRATION AND ROTATION, INCLUDING +C CENTRIFUGAL DISTORTION. (THE (J(J+1))**2 AND (J(J+1))**3 +C PROVIDE FOR CENTRIFUGAL DISTORTION; THE VP AND VP**2 IN THE +C ROTATION TERMS PROVIDE FOR COUPLING BETWEEN VIBRATION AND +C ROTATION.) +C THE FORMULA OF COHEN AND BIRNBAUM(1981), +C NU = 59.3392*(J(J+1)) - 0.04599*(J(J+1))**2 +C + 0.000052*(J(J+1))**3 CM-1, +C IS A SPECIAL CASE OF THE FORMULA USED HERE, OBTAINED BY +C SETTING V=0 (IE., VP = 1/2); THE VP TERMS IN THE VIBRATION- +C ROTATION CONTRIBUTIONS CORRECT THE INITIAL TERMS TO +C PRODUCE THE COEFFICIENTS IN THE COHEN AND BIRNBAUM FORMULA. +C FOR THE COLD ATMOSPHERES OF THE OUTER PLANETS, THE SIGNIF- +C ICANTLY POPULATED LEVELS HAVE V=0. +C +C*********************************************************************** +C + IMPLICIT REAL (A-H,O-Z) + REAL J,JP +C + VP = V + 0.5 + JP = J + 1.0 + E = 4400.39*VP - 120.815*VP**2 + 0.7242*VP**3 + + A (60.841 - 3.0177*VP + 0.0286*VP**2)*J*JP - + B (0.04684 - 0.00171*VP + 3.1E-05*VP**2)*J**2*JP**2 + + C 5.2E-05*J**3*JP**3 - 2170.08 + H2ENER = E + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/heating.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/heating.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/heating.F (revision 1643) @@ -0,0 +1,124 @@ + SUBROUTINE heating(dist,rmu0,fract,falbe,sol_htg,zswup,zswdn, + . icld) + + +c======================================================================= +c +c Object: Computation of the solar heating rate +c SOL_HTG(klon,klev) +c +c Arguments: +c ---------- +c +c Input: +c ------ +c +c dist-----input-R- distance astronomique terre-soleil +c rmu0-----input-R- cosinus de l'angle zenithal +c fract----input-R- duree d'ensoleillement normalisee +c falbe----input-R- surface albedo +c icld-----input-I- calcul avec nuages. +c p(klon,nl) pressure (level) +c +c Output: +c ------- +c sol_htg-----output-R- echauffement atmospherique (visible) (K/s) +c zswup-------output-R- flux solaire upward (+ vers le haut) (W/m2) +c zswdn-------output-R- flux solaire downward (+ vers le bas) (W/m2) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + + use dimphy + use TGMDAT_MOD, ONLY: UBARI,UBARV,UBAR0 + use TGMDAT_MOD, ONLY: CSUBP,F0PI + IMPLICIT NONE + include "dimensions.h" + + INTEGER NLEVEL,NLAYER,NSPECV + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECV=24) +c +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c + +c Arguments: +c ---------- + + + real dist, rmu0(klon), fract(klon), falbe(klon) + integer icld + + real sol_htg(klon,klev) + real zswup(klon,klev+1) + real zswdn(klon,klev+1) + +c Local: +c ------ + + INTEGER I,J,IG,K,IPRINT,ilat,nq + +c COMMONS for interface with local subroutines: +c --------------------------------------------- + + REAL CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + REAL XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + REAL FNETV(ngrid,NLEVEL),FUPV(ngrid,NLEVEL,NSPECV) + REAL FDV(ngrid,NLEVEL,NSPECV),FMNETV(ngrid,NLEVEL) + + COMMON /GASS/ CH4,XN2 + & ,H2,AR + & ,XMU,GAS1 + & ,COLDEN + + COMMON /FLUXvV/ FNETV, + & FUPV, + & FDV, + & FMNETV + + +c================================================================== + + fnetv = 0.0 + sol_htg= 0.0 + zswup = 0.0 + zswdn = 0.0 +c pour sorties dans gfluxv... + iprint = 0 + + DO ig=1,klon + IF(fract(ig).LT.1.e-5) THEN + DO j=1,nlayer + sol_htg(ig,j)=0. + ENDDO + ELSE + ubar0=rmu0(ig) + + CALL sfluxv(iprint,ig,dist,falbe,icld) ! #3 + + do K=1,NSPECV + zswup(ig,:) = zswup(ig,:)+FUPV(ig,:,K)*fract(ig) ! >0 up + zswdn(ig,:) = zswdn(ig,:)+FDV(ig,:,K) *fract(ig) ! >0 down + enddo + fnetv(ig,:) = fnetv(ig,:) *fract(ig) ! >0 up + +c conversion en W/m2: + zswup(ig,:) = 1.e-3*zswup(ig,:) + zswdn(ig,:) = 1.e-3*zswdn(ig,:) + + DO j=1,nlayer + sol_htg(ig,j)= ! K/s + s (fnetv(ig,j+1)-fnetv(ig,j)) + s /(colden(j)*csubp) + ENDDO + ENDIF + ENDDO + + RETURN + 191 FORMAT(F8.2,1P10E10.2) + 192 FORMAT(a8,1P10E10.2) + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/hgardfou.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/hgardfou.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/hgardfou.F (revision 1643) @@ -0,0 +1,113 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/hgardfou.F,v 1.1.1.1 2004/05/19 12:53:07 lmdzadmin Exp $ +! + SUBROUTINE hgardfou (t,tsol,text) + + use dimphy + IMPLICIT none +c====================================================================== +c Verifier la temperature +c====================================================================== +#include "YOMCST.h" + REAL t(klon,klev), tsol(klon) + CHARACTER*(*) text +C + INTEGER i, k + REAL zt(klon) + INTEGER jadrs(klon), jbad + LOGICAL ok +c + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + IF (firstcall) THEN + PRINT*, 'hgardfou garantit la temperature dans [20,1200] K' + firstcall = .FALSE. + ENDIF +c + ok = .TRUE. + DO k = 1, klev + DO i = 1, klon + zt(i) = t(i,k) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 1200.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).GT.1200.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i)) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 20.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).LT.20.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i)) + ENDDO + ENDIF + ENDDO +c + DO i = 1, klon + zt(i) = tsol(i) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 1200.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).GT.1200.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,temperature =',jadrs(i),zt(jadrs(i)) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 20.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).LT.20.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,temperature =',jadrs(i),zt(jadrs(i)) + ENDDO + ENDIF +c + IF (.NOT. ok) THEN + PRINT*, 'hgardfou s arrete ', text + CALL abort + ENDIF + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/infotrac_phy.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/infotrac_phy.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/infotrac_phy.F90 (revision 1643) @@ -0,0 +1,48 @@ + +! $Id: $ + +MODULE infotrac_phy + +! Infotrac for physics; contains the same information as infotrac for +! the dynamics + IMPLICIT NONE + +! iflag_trac: ==1 if running with tracers + INTEGER,SAVE :: iflag_trac +!$OMP THREADPRIVATE(iflag_trac) + +! nqtot : total number of tracers + INTEGER,SAVE :: nqtot +!$OMP THREADPRIVATE(nqtot) + +! tracer names + CHARACTER(len=20),ALLOCATABLE,DIMENSION(:),SAVE :: tname + CHARACTER(len=23),ALLOCATABLE,DIMENSION(:),SAVE :: ttext ! tracer long name for diagnostics +!$OMP THREADPRIVATE(tname,ttext) + +CONTAINS + + SUBROUTINE init_infotrac_phy(iflag_trac_,nqtot_,tname_,ttext_) + ! Initialize module variables + IMPLICIT NONE + + INTEGER,INTENT(IN) :: iflag_trac_ ! ==1 if running with tracers + INTEGER,INTENT(IN) :: nqtot_ ! total number of tracers + CHARACTER(LEN=*),INTENT(IN) :: tname_(nqtot_) + CHARACTER(LEN=*),INTENT(IN) :: ttext_(nqtot_) + + INTEGER :: iq + + iflag_trac=iflag_trac_ + nqtot=nqtot_ + + ALLOCATE(tname(nqtot)) + ALLOCATE(ttext(nqtot)) + DO iq=1,nqtot + tname(iq)=tname_(iq) + ttext(iq)=ttext_(iq) + ENDDO + + END SUBROUTINE init_infotrac_phy + +END MODULE infotrac_phy Index: trunk/LMDZ.TITAN.old/libf/phytitan/ini_histday.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ini_histday.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ini_histday.h (revision 1643) @@ -0,0 +1,361 @@ + IF (ok_journe) THEN + + zsto = dtime + zout = dtime * REAL(ecrit_day) +c zsto1: pour des flux radiatifs calcules tous les radpas appels physiq + zsto1= dtime * REAL(radpas) + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, zero, zjulian) + + CALL histbeg_phy("histday.nc", itau_phy, zjulian, dtime, + . nhori, nid_day) + +!$OMP MASTER + CALL histvert(nid_day, "presnivs", "Vertical levels", "Pa", + . klev, presnivs, nvert) + +c------------------------------------------------------- + IF(lev_histday.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + CALL histdef(nid_day, "phis", "Surface geop. height", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + + CALL histdef(nid_day, "aire", "Grid area", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + +ccccccc axe Ls + CALL histdef(nid_day, "ls", "Solar longitude", "degrees", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + +ccccccccccccc 2D fields, variables + + CALL histdef(nid_day, "tsol", "Surface Temperature", "K", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "psol", "Surface Pressure", "Pa", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + +c CALL histdef(nid_day, "ue", "Zonal energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + +c CALL histdef(nid_day, "ve", "Merid energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histday.GE.1 + +c------------------------------------------------------- + IF(lev_histday.GE.2) THEN + +ccccccccccccc 3D fields, basics + + CALL histdef(nid_day, "temp", "Air temperature", "K", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "pres", "Air pressure", "Pa", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "geop", "Geopotential height", "m", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "vitu", "Zonal wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "vitv", "Meridional wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "vitw", "Vertical wind", "Pa/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_day, "duvdf", "Boundary-layer dU", "m/s2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dudyn", "Dynamics dU", "m/s2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.ge.1) then +c DO iq=1,nmicro +c CALL histdef(nid_day, tname(iq), ttext(iq), "n/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) +c ENDDO + CALL histdef(nid_day, "qaer","nb tot aer" , "n/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + if (clouds.eq.1) then + CALL histdef(nid_day, "qnoy","nb tot noy" , "n/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day, "qgl1","V tot gl1" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day, "qgl2","V tot gl2" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day, "qgl3","V tot gl3" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c-------------- +c ----- SATURATION ESP NUAGES + CALL histdef(nid_day,"ch4sat", "saturation CH4", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"c2h6sat", "saturation C2H6", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"c2h2sat", "saturation C2H2", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- RESERVOIR DE SURFACE + CALL histdef(nid_day, "reserv", "Reservoir surface","m", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- ECHANGE GAZ SURF/ATM (evaporation) + CALL histdef(nid_day, "evapch4", "Evaporation CH4","m", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- PRECIPITATIONS (precipitations cumulatives) + CALL histdef(nid_day,"prech4","Precip CH4","m", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"prec2h6","Precip C2H6", + . "m",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"prec2h2","Precip C2H2", + . "m",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"prenoy","Precip NOY", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"preaer","Precip AER", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- FLUX GLACE + CALL histdef(nid_day,"flxgl1", "flux gl CH4", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"flxgl2", "flux gl C2H6", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) + CALL histdef(nid_day,"flxgl3", "flux gl C2H2", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) +c -------------- +c ----- RAYON DES GOUTTES + CALL histdef(nid_day,"rcldbar", "rayon moyen goutte", + . "m",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + endif + endif +c -------------- +c ----- TRACEURS CHIMIQUES + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + CALL histdef(nid_day, tname(iq), ttext(iq), "ppm", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO + endif + endif + + ENDIF !lev_histday.GE.2 + +c------------------------------------------------------- + IF(lev_histday.GE.3) THEN + +cccccccccccccccccc Radiative transfer + +c 2D + + CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_day, "sols", "Solar rad. at surf.", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_day, "soll", "IR rad. at surface", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + +c 3D + + CALL histdef(nid_day, "SWnet", "Net SW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto1,zout) + + CALL histdef(nid_day, "LWnet", "Net LW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto1,zout) + +c -------------- +c ----- OPACITE BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"thv"//str2,"Haze Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"thi"//str2,"Haze Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- EXTINCTION BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"khv"//str2,"Haze ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"khi"//str2,"Haze ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- OPACITE GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"tgv"//str2,"Gas Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"tgi"//str2,"Gas Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- EXTINCTION GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"kgv"//str2,"Gas ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_day,"kgi"//str2,"Gas ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- OPACITE NUAGES + if (clouds.eq.1) then + CALL histdef(nid_day,"tcld","Cld Opa proxy", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto,zout) + +c -------------- +c ----- EXTINCTION NUAGES + CALL histdef(nid_day,"kcld","Cld Ext proxy", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto,zout) + endif + + ENDIF !lev_histday.GE.3 + +c------------------------------------------------------- + IF(lev_histday.GE.4) THEN + + CALL histdef(nid_day, "dtdyn", "Dynamics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dtphy", "Physics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dtvdf", "Boundary-layer dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dtajs", "Dry adjust. dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dtswr", "SW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_day, "dtlwr", "LW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +c CALL histdef(nid_day, "dtec", "Cinetic dissip dT", "K/s", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histday.GE.4 + +c------------------------------------------------------- + IF(lev_histday.GE.5) THEN + + +c call histdef(nid_day, "taux", +c $ "Zonal wind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "ave(X)", zsto,zout) + +c call histdef(nid_day, "tauy", +c $ "Meridional xind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "ave(X)", zsto,zout) + +c CALL histdef(nid_day, "cdrm", "Momentum drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + +c CALL histdef(nid_day, "cdrh", "Heat drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histday.GE.5 +c------------------------------------------------------- + + CALL histend(nid_day) + + ENDIF ! fin de test sur ok_journe Index: trunk/LMDZ.TITAN.old/libf/phytitan/ini_histins.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ini_histins.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ini_histins.h (revision 1643) @@ -0,0 +1,276 @@ + IF (ok_instan) THEN + + zsto = dtime * REAL(ecrit_ins) + zout = dtime * REAL(ecrit_ins) + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, zero, zjulian) + + CALL histbeg_phy("histins.nc", itau_phy, zjulian, dtime, + . nhori, nid_ins) + +!$OMP MASTER + CALL histvert(nid_ins, "presnivs", "Vertical levels", "Pa", + . klev, presnivs, nvert) + +c------------------------------------------------------- + + IF(lev_histday.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + CALL histdef(nid_ins, "phis", "Surface geop. height", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + + CALL histdef(nid_ins, "aire", "Grid area", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + +ccccccc axe Ls + CALL histdef(nid_ins, "ls", "Solar longitude", "degrees", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + +ccccccccccccc 2D fields, variables + + CALL histdef(nid_ins, "tsol", "Surface Temperature", "K", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "ue", "Zonal energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "ve", "Merid energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "inst(X)", zsto,zout) + + ENDIF !lev_histday.GE.1 + +c------------------------------------------------------- + IF(lev_histday.GE.2) THEN + +ccccccccccccc 3D fields, basics + + CALL histdef(nid_ins, "temp", "Air temperature", "K", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "pres", "Air pressure", "Pa", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "geop", "Geopotential height", "m", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "vitv", "Meridional wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "vitw", "Vertical wind", "Pa/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "tops", "Solar rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "duvdf", "Boundary-layer dU", "m/s2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "dudyn", "Dynamics dU", "m/s2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "inst(X)", zsto,zout) + + ENDIF !lev_histday.GE.2 + +c------------------------------------------------------- + IF(lev_histday.GE.3) THEN + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.ge.1) then + DO iq=1,nmicro + CALL histdef(nid_ins, tname(iq), ttext(iq), "n/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + ENDDO + endif + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + CALL histdef(nid_ins, tname(iq), ttext(iq), "ppm", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + ENDDO + endif + endif + +cccccccccccccccccc Radiative transfer + +c 2D + + CALL histdef(nid_ins, "topl", "IR rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "inst(X)", zsto,zout) + +c 3D + + CALL histdef(nid_ins, "SWnet", "Net SW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "LWnet", "Net LW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "inst(X)", zsto,zout) + +c -------------- +c ----- OPACITE BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"thv"//str2,"Haze Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"thi"//str2,"Haze Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + +c -------------- +c ----- EXTINCTION BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"khv"//str2,"Haze ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"khi"//str2,"Haze ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + +c -------------- +c ----- OPACITE GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"tgv"//str2,"Haze Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"tgi"//str2,"Haze Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + +c -------------- +c ----- EXTINCTION GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"kgv"//str2,"Haze ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_ins,"kgi"//str2,"Haze ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ins(X)",zsto,zout) + ENDDO + + ENDIF !lev_histday.GE.3 + +c------------------------------------------------------- + IF(lev_histday.GE.4) THEN + + CALL histdef(nid_ins, "dtdyn", "Dynamics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "dtphy", "Physics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "dtajs", "Dry adjust. dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "dtswr", "SW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "dtlwr", "LW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "dtec", "Cinetic dissip dT", "K/s", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "dvvdf", "Boundary-layer dV", "m/s2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "inst(X)", zsto,zout) + + ENDIF !lev_histday.GE.4 + +c------------------------------------------------------- + IF(lev_histday.GE.5) THEN + + +c call histdef(nid_ins, "taux", +c $ "Zonal wind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "inst(X)", zsto,zout) + +c call histdef(nid_ins, "tauy", +c $ "Meridional xind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "inst(X)", zsto,zout) + +c CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "inst(X)", zsto,zout) + + ENDIF !lev_histday.GE.5 +c------------------------------------------------------- + + CALL histend(nid_ins) + + ENDIF Index: trunk/LMDZ.TITAN.old/libf/phytitan/ini_histmth.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ini_histmth.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ini_histmth.h (revision 1643) @@ -0,0 +1,427 @@ + IF (ok_mensuel) THEN + + zsto = dtime + zout = dtime * REAL(ecrit_mth) +c zsto1: pour des flux radiatifs calcules tous les radpas appels physiq + zsto1= dtime * REAL(radpas) + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, zero, zjulian) + + CALL histbeg_phy("histmth.nc", itau_phy, zjulian, dtime, + . nhori, nid_mth) + +!$OMP MASTER + CALL histvert(nid_mth, "presnivs", "Vertical levels", "Pa", + . klev, presnivs, nvert) + +c------------------------------------------------------- + IF(lev_histmth.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + CALL histdef(nid_mth, "phis", "Surface geop. height", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + + CALL histdef(nid_mth, "aire", "Grid area", "-", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "once", zsto,zout) + +ccccccc axe Ls + CALL histdef(nid_mth, "ls", "Solar longitude", "degrees", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + +ccccccccccccc 2D fields, variables + + CALL histdef(nid_mth, "tsol", "Surface Temperature", "K", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "ue", "Zonal energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "ve", "Merid energy transport", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histmth.GE.1 + +c------------------------------------------------------- + IF(lev_histmth.GE.2) THEN + +ccccccccccccc 3D fields, basics + + CALL histdef(nid_mth, "temp", "Air temperature", "K", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "pres", "Air pressure", "Pa", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "geop", "Geopotential height", "m", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "Kz", "vertical diffusion coef", "m2/s", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dudyn", "Dynamics dU", "m/s2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.ge.1) then +c DO iq=1,nmicro +c CALL histdef(nid_mth, tname(iq), ttext(iq), "n/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) +c ENDDO + CALL histdef(nid_mth, "qaer","nb tot aer" , "n/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + if (clouds.eq.1) then + CALL histdef(nid_mth, "qnoy","nb tot noy" , "n/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth, "qgl1","V tot gl1" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth, "qgl2","V tot gl2" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth, "qgl3","V tot gl3" , "m3/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c-------------- +c ----- SATURATION ESP NUAGES + CALL histdef(nid_mth,"ch4sat", "saturation CH4", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"c2h6sat", "saturation C2H6", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"c2h2sat", "saturation C2H2", "--", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- RESERVOIR DE SURFACE + CALL histdef(nid_mth, "reserv", "Reservoir surface","m", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- ECHANGE GAZ SURF/ATM (evaporation) + CALL histdef(nid_mth, "evapch4", "Evaporation CH4","m", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- PRECIPITATIONS (precipitations moyennes) + CALL histdef(nid_mth,"prech4","Precip CH4","um/s", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"prec2h6","Precip C2H6", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"prec2h2","Precip C2H2", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"prenoy","Precip NOY", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"preaer","Precip AER", + . "um/s",nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- FLUX GLACE + CALL histdef(nid_mth,"flxgl1", "flux gl CH4", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"flxgl2", "flux gl C2H6", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"flxgl3", "flux gl C2H2", + . "kg/m2/s",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)", zsto,zout) +c -------------- +c ----- Source/puits GLACE + CALL histdef(nid_mth,"solch4", "dQ gl CH4", + . "m3/m3",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"solc2h6", "dQ gl C2H6", + . "m3/m3",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth,"solc2h2", "dQ gl C2H2", + . "m3/m3",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c -------------- +c ----- RAYON DES GOUTTES + CALL histdef(nid_mth,"rcldbar", "rayon moyen goutte", + . "m",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + endif + endif +c -------------- +c ----- TRACEURS CHIMIQUES + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + CALL histdef(nid_mth, tname(iq), ttext(iq), "ppm", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO +c Condensation: +c DO iq=nmicro+1,nqmax +c CALL histdef(nid_mth, "c_"//tname(iq), "c_"//ttext(iq), +c . "ppm/s",nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) +c ENDDO + endif + endif + + ENDIF !lev_histmth.GE.2 + +c------------------------------------------------------- + IF(lev_histmth.GE.3) THEN + +cccccccccccccccccc Radiative transfer + +c 2D + + CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + + CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2", + . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, + . "ave(X)", zsto1,zout) + +c 3D + + CALL histdef(nid_mth, "SWnet", "Net SW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto1,zout) + +c CALL histdef(nid_mth, "SWup", "upward SW flux","W/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, +c . 32, "ave(X)", zsto1,zout) + +c CALL histdef(nid_mth, "SWdn", "downward SW flux","W/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, +c . 32, "ave(X)", zsto1,zout) + + CALL histdef(nid_mth, "LWnet", "Net LW flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto1,zout) + +c CALL histdef(nid_mth, "LWup", "upward LW flux","W/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, +c . 32, "ave(X)", zsto1,zout) + +c CALL histdef(nid_mth, "LWdn", "downward LW flux","W/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, +c . 32, "ave(X)", zsto1,zout) + + CALL histdef(nid_mth, "fluxvdf", "PBL net flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "fluxdyn", "Dyn. net flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "fluxajs", "Dry adj. net flux","W/m2", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, + . 32, "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "fluxec", "Cin. net flux","W/m2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, +c . 32, "ave(X)", zsto,zout) + +c -------------- +c ----- OPACITE BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"thv"//str2,"Haze Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"thi"//str2,"Haze Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- EXTINCTION BRUME + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"khv"//str2,"Haze ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"khi"//str2,"Haze ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- OPACITE GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"tgv"//str2,"Gas Opa Vis", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"tgi"//str2,"Haze Opa IR", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- EXTINCTION GAZ + DO k=7,NSPECV,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"kgv"//str2,"Gas ext Vis ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + + DO k=8,NSPECI,10 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"kgi"//str2,"Gas ext IR ", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto1,zout) + ENDDO + +c -------------- +c ----- OPACITE NUAGES + if (clouds.eq.1) then + CALL histdef(nid_mth,"tcld","Cld Opa proxy", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto,zout) + +c -------------- +c ----- EXTINCTION NUAGES + CALL histdef(nid_mth,"kcld","Cld Ext proxy", + . "m-1",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto,zout) + endif + +c -------------- +c ----- OCCURENCE NUAGES + do k=1,12 + write(str2,'(i2.2)') k + CALL histdef(nid_mth,"occcld"//str2,"occ cld", + . "--",nbp_lon,jj_nb,nhori,klev,1,klev,nvert,32, + . "ave(X)",zsto,zout) + enddo + + ENDIF !lev_histmth.GE.3 + +c------------------------------------------------------- + IF(lev_histmth.GE.4) THEN + + CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s", + . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2", +c . nbp_lon,jj_nb,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histmth.GE.4 + +c------------------------------------------------------- + IF(lev_histmth.GE.5) THEN + + +c call histdef(nid_mth, "taux", +c $ "Zonal wind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "ave(X)", zsto,zout) + +c call histdef(nid_mth, "tauy", +c $ "Meridional xind stress", "Pa", +c $ nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c $ "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + +c CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-", +c . nbp_lon,jj_nb,nhori, 1,1,1, nvert, 32, +c . "ave(X)", zsto,zout) + + ENDIF !lev_histmth.GE.5 +c------------------------------------------------------- + + CALL histend(nid_mth) + + ENDIF ! fin de test sur ok_journe Index: trunk/LMDZ.TITAN.old/libf/phytitan/inicondens.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/inicondens.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/inicondens.F (revision 1643) @@ -0,0 +1,200 @@ + SUBROUTINE inicondens(ny,press,temp,nomy,yc) + +c======================================================================= +c initialisation des profils de saturation des traceurs +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + use dimphy + use mod_grid_phy_lmdz, only: nbp_lev + IMPLICIT NONE +#include "YOMCST.h" + +c Arguments : +c ----------- + INTEGER ny + real press(nbp_lev),temp(nbp_lev) ! pressure in mbar ! + REAL yc(nbp_lev,ny) + character*10 nomy(ny+1) + +c Local variables : +c ----------------- + INTEGER l,ic + real sy,x + + do ic=1,ny + print*, 'traceur CH(', ic, ')=', nomy(ic),'------------' + do l=1,nbp_lev + +c Par defaut, yc est a 1 c'est a dire qu'on ne condense pas + yc(l,ic)=1. + + if(nomy(ic).eq."CH4") then + if (temp(l).lt.90.65) then + yc(l,ic)= + s 10.0**(4.42507e0 - ( ( ( 1165560.7e0 / TEMP(l) - + s 115352.19e0 ) / TEMP(l) + 4055.6016e0 ) / TEMP(l) + s + 453.92414e0 ) / TEMP(l) ) / PRESS(l) * 1013.25e0 + else + yc(l,ic)= + s 10.0**(3.901408e0 - ( ( 154567.02e0 / TEMP(l) - + s 1598.8512e0 ) / TEMP(l) + 437.54809e0 ) / TEMP(l)) + s / PRESS(l) * 1013.25e0; + endif +c maintient a 1.4% minimum + if (yc(l,ic).lt.0.014) yc(l,ic)=0.014 + endif + + if(nomy(ic).eq."C2H2") then + yc(l,ic)= + s 10.0**(6.09748e0-1644.1e0/TEMP(l)+7.42346e0 + s * alog10(1.0e3/TEMP(l)) ) / PRESS(l)*1013.25e0/760.0 + endif + + if(nomy(ic).eq."C2H4") then + if (temp(l).lt.89.0) then + yc(l,ic)= + s 10.0**(1.5477e0 + (1.0e0/TEMP(l) - 0.011e0) + s *(16537.0e0*(1.0e0/TEMP(l) - 0.011e0) - 1038.1e0)) + s / PRESS(l) * 1.01325e0 / 760.0 + elseif (temp(l).lt.104.0) then + yc(l,ic)= + s 10.0**(8.724e0 - 901.6e0/(TEMP(l) - 2.555e0) ) + s / PRESS(l) * 1013.25e0 / 760.0 + elseif (temp(l).lt.120.0) then + yc(l,ic)= + s 10.0**(50.79e0 - 1703.0e0/TEMP(l) - 17.141e0 * + s alog10(TEMP(l)) ) / PRESS(l) * 1013.25e0 / 760.0 + elseif (temp(l).lt.155.0) then + yc(l,ic)= + s 10.0**(6.74756e0 - 585.0e0/(TEMP(l) - 18.16e0) ) + s / PRESS(l) * 1013.25e0 / 760.0 + endif + endif + + if(nomy(ic).eq."C2H6") then + if (temp(l).lt.90.) then + yc(l,ic)= + s 10.0**(10.01e0-1085.0e0/(TEMP(l)-0.561e0) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + else + yc(l,ic)= + s 10.0**(5.9366e0 - 1086.17e0/TEMP(l) + 3.83464e0 * + s alog10(1.0e3/TEMP(l)) ) / PRESS(l)*1013.25e0/760.0 + endif + endif + + if((nomy(ic).eq."CH3CCH") + s .or.(nomy(ic).eq."CH2CCH2")) then + yc(l,ic)= + s 10.0**(2.8808e0 - 4.5e0*(249.9e0 - TEMP(l)) + s /(1.15e0*TEMP(l) - 37.485e0) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C3H6") then + yc(l,ic)= + s 10.0**(7.4463e0 - 1028.5654e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C3H8") then + yc(l,ic)= + s 10.0**(7.217e0 - 994.30251e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if((nomy(ic).eq."C4H2") + s .or.(nomy(ic).eq."C4H2s")) then + yc(l,ic)= + s 10.0**(96.26781e0 - 4651.872e0/TEMP(l) - 31.68595e0 + s *alog10(TEMP(l)) ) / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C4H4") then + yc(l,ic)= + s 1.0e3 * exp(9.3898e0 - 2203.57/(TEMP(l)-43.15e0) ) + s / PRESS(l) + endif + + if(nomy(ic).eq."C4H6") then + yc(l,ic)= + s 10.0**(2.8808e0 - 4.6e0*(262.3e0 - TEMP(l)) + s /(1.15e0*TEMP(l) - 39.345e0) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C4H10") then + yc(l,ic)= + s 10.0**(8.446e0 - 1461.2e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C6H2") then + yc(l,ic)= + s 10.0**(4.666e0 - 4956e0/TEMP(l) + 25.845e0 * + s alog10(1.0e3/TEMP(l)) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C8H2") then + yc(l,ic)= + s 10.0**(3.95e0 - 6613e0/TEMP(l) + 35.055e0 * + s alog10(1.0e3/TEMP(l)) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."AC6H6") then + x = 1.0e0 - TEMP(l) / 562.2e0 + yc(l,ic)= + s 48.9e3 * exp( ( 1.33213 * x**1.5 - 6.98273 * x + s - x**3 * (2.62863 + 3.33399 * x**3) ) + s * 562.2e0/TEMP(l) ) / PRESS(l) + endif + + if(nomy(ic).eq."HCN") then + yc(l,ic)= + s 10.0**(8.6165e0 - 1516.5e0/(TEMP(l) - 26.2e0) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."CH3CN") then + yc(l,ic)= + s 10.0**(8.458e0 - 1911.7e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C2H3CN") then + yc(l,ic)= + s 10.0**(9.3051e0 - 2782.21/(TEMP(l) - 51.15e0) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."NCCN") then + yc(l,ic)= + s 10.0**(7.454e0 - 1832e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."HC3N") then + yc(l,ic)= + s 10.0**(7.7446e0 - 1453.5609e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + if(nomy(ic).eq."C4N2") then + yc(l,ic)= + s 10.0**(8.269e0 - 2155.0e0/TEMP(l) ) + s / PRESS(l) * 1013.25e0 / 760.0e0 + endif + + enddo + enddo + + print*, 'inicondens end' + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/inimuphy3D.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/inimuphy3D.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/inimuphy3D.F (revision 1643) @@ -0,0 +1,118 @@ + +************************************************************************ +* inimphycst() +* initialise les constante utilisée dans la microphysique. +* +* Oui je sais certaine constantes, voir toutes les definitions +* faites ici devraient etre dans YOMCST.h mais la j'ai pas le +* courage pour le moment ! +************************************************************************ + subroutine inimphycst() + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" +#include "YOMCST.h" + + pi = RPI + + nav = RNAVO + rgp = R + kbz = RKBOL + + rtit = RA + g0 = RG + + mch4 = 16.e-3 ! kg/mol !!!! + mc2h6 = 30.e-3 + mc2h2 = 26.e-3 + mar = 36.4e-3 + mn2 = 28.e-3 + mair = 28.e-3 ! l'air c'est du N2 ^^ + + rhol = 1.e+3 ! rho aerosols + rhoi_ch4 = 425. + rhoi_c2h6 = 544.6 + rhoi_c2h2 = 615.0 + + mtetach4 = 0.92 + mtetac2h6 = 0.92 + mtetac2h2 = 0.92 + + return + end +************************************************************************ +* Routine calculant/initialisant la grille verticale +* ainsi que tous les variables communes aux routines microphysique. +* +* CONVENTION : +* suffixe b : bord des couches. +* SANS suffixe : centre des couches. +************************************************************************ + subroutine inimuphy(ihor,tplev,tplay,tzlev,tzlay,tpt) + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" +* +* INPUT : +* + integer ihor + real tplev(nz+1),tplay(nz),tzlev(nz+1),tzlay(nz),tpt(nz) +* +* LOCAL +* + integer i,j + real plev(nz+1),play(nz),zlev(nz+1),zlay(nz),pt(nz) + + + if (nz.ne.llm) then + print*," dans inimuphys !" + STOP + endif + +*----------------------- +* INVERSION DES TABLEAUX +*----------------------- + + do j=1,nz+1 + plev(j)=tplev(nz-j+2) + zlev(j)=tzlev(nz-j+2) + enddo + do j=1,nz + play(j)=tplay(nz-j+1) + zlay(j)=tzlay(nz-j+1) + pt(j) = tpt(nz-j+1) + enddo +* +* Calcul de la grille verticale : +* z,dz,zb,dzb +* + do i=1,nz-1 + dz(i)=zlay(i)-zlay(i+1) + dzb(i)=zlev(i)-zlev(i+1) + enddo + dz(nz)=dz(nz-1) ! ARBITRAIRE + dzb(nz)=zlev(nz)-zlev(nz+1) + z=zlay + zb=zlev + p=play + pb=plev + +* +* conditions speciale pour le dernier niveau de pression +* on crée un niveau tres tres tres fin mais qui existe quand meme !) + pb(1) = plev(2)*1.e-7 + + +c Interpolation de tb a partir de t +c******************************************************* + t=pt + do i=1,nz-1 + tb(i+1)=(t(i)+t(i+1))/2. + enddo + tb(1)=t(1) + tb(nz+1)=(t(nz)-t(nz-1))*.5+t(nz) + + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/iniorbit.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/iniorbit.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/iniorbit.F (revision 1643) @@ -0,0 +1,103 @@ + SUBROUTINE iniorbit + $ (paphelie,pperiheli,pyear_day,pperi_day,pobliq) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: +c ------- +c Frederic Hourdin 22 Fevrier 1991 +c +c Objet: +c ------ +c Initialisation du sous programme orbite qui calcule +c a une date donnee de l'annee de duree year_day commencant +c a l'equinoxe de printemps et dont le perihelie se situe +c a la date peri_day, la distance au soleil et la declinaison. +c +c Interface: +c ---------- +c - Doit etre appele avant d'utiliser orbite. +c - initialise le common comorbit +c +c Arguments: +c ---------- +c +c Input: +c ------ +c aphelie \ aphelie et perihelie de l'orbite +c periheli / en millions de kilometres. +c +c======================================================================= + +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comorbit.h" + +c Arguments: +c ---------- + + REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq + +c Local: +c ------ + + REAL zxref,zanom,zz,zx0,zdx + INTEGER iter + +c----------------------------------------------------------------------- + + aphelie =paphelie + periheli=pperiheli + year_day=pyear_day + obliquit=pobliq + peri_day=pperi_day + + pi=2.*asin(1.) + PRINT*,'Perihelie en Mkm ',periheli + PRINT*,'Aphelise en Mkm ',aphelie + PRINT*,'obliquite en degres :',obliquit + unitastr=149.597927 + e_elips=(aphelie-periheli)/(periheli+aphelie) + p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr + + print*,'e_elips',e_elips + print*,'p_elips',p_elips + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c calcul de l'zanomalie moyenne + + zz=(year_day-pperi_day)/year_day + zanom=2.*pi*(zz-nint(zz)) + zxref=abs(zanom) + PRINT*,'year_day ',year_day + PRINT*,'pperi_day ',pperi_day + PRINT*,'zanom ',zanom + +c resolution de l'equation horaire zx0 - e * sin (zx0) = zxref +c methode de Newton + + zx0=zxref+e_elips*sin(zxref) + DO 110 iter=1,100 + zdx=-(zx0-e_elips*sin(zx0)-zxref)/(1.-e_elips*cos(zx0)) + if(abs(zdx).le.(1.e-12)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + PRINT*,'zx0 ',zx0 + +c zteta est la longitude solaire + + timeperi=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + PRINT*,'longitude solaire du perihelie = ', + . -180/3.1416*timeperi + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/interface_surf.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/interface_surf.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/interface_surf.F90 (revision 1643) @@ -0,0 +1,343 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/interface_surf.F90,v 1.6 2005/02/24 09:58:18 fairhead Exp $ +! + + MODULE interface_surf + +! Ce module regroupe toutes les routines gerant l'interface entre le modele +! atmospherique et les modeles de surface (sols continentaux, oceans, glaces) +! Les routines sont les suivantes: +! +! interfsurf_*: routines d'aiguillage vers les interfaces avec les +! differents modeles de surface +! +! L. Fairhead, LMD, 02/2000 + + USE ioipsl + + IMPLICIT none + + PRIVATE + PUBLIC :: interfsurf,interfsurf_hq + + INTERFACE interfsurf + module procedure interfsurf_hq + END INTERFACE + +#include "YOMCST.h" + + CONTAINS +! +!############################################################################ +! +! ADAPTATION GCM POUR CP(T) + SUBROUTINE interfsurf_hq(itime, dtime, rmu0, & + & klon, iim, jjm, knon, & + & rlon, rlat, cufi, cvfi, & + & debut, lafin, soil_model, nsoilmx, tsoil, & + & zlev, u1_lay, v1_lay, temp_air, epot_air, & + & tq_cdrag, petAcoef, petBcoef, & + & sollw, sollwdown, swnet, swdown, & + & fder, taux, tauy, & + & albedo, & + & tsurf, pkh1, p1lay, radsol, & + & fluxsens, dflux_s, & + & tsol_rad, tsurf_new, alb_new) + + use write_field_phy + use cpdet_phy_mod, only: cpdet + + IMPLICIT none + +! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general +! (sols continentaux, oceans, glaces) pour les fluxs de chaleur et d'humidite. +! En pratique l'interface se fait entre la couche limite du modele +! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...) +! +! +! L.Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! klon nombre total de points de grille +! iim, jjm nbres de pts de grille +! dtime pas de temps de la physique (en s) +! rmu0 cosinus de l'angle solaire zenithal +! knon nombre de points de la surface a traiter +! rlon longitudes +! rlat latitudes +! cufi,cvfi resolution des mailles en x et y (m) +! debut logical: 1er appel a la physique +! lafin logical: dernier appel a la physique +! zlev hauteur de la premiere couche +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! epot_air temp potentielle de l'air +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! petBcoef coeff. B de la resolution de la CL pour t +! sollw flux IR net a la surface +! sollwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! albedo albedo de la surface +! tsurf temperature de surface +! pkh1 fct Exner à la surface: RCPD*(paprs(1)/preff)**RKAPPA +! p1lay pression 1er niveau (milieu de couche) +! radsol rayonnement net aus sol (LW + SW) +! fder derivee des flux (pour le couplage) +! taux, tauy tension de vents +! +! output: +! fluxsens flux de chaleur sensible +! tsol_rad +! tsurf_new temperature au sol +! alb_new albedo + +#include "iniprint.h" + + +! Parametres d'entree + integer, intent(IN) :: itime + integer, intent(IN) :: iim, jjm + integer, intent(IN) :: klon + real, intent(IN) :: dtime + real, intent(IN) :: rmu0(klon) + integer, intent(IN) :: knon + logical, intent(IN) :: debut, lafin + real, dimension(klon), intent(IN) :: rlon, rlat + real, dimension(klon), intent(IN) :: cufi, cvfi + real, dimension(klon), intent(INOUT) :: tq_cdrag + real, dimension(klon), intent(IN) :: zlev + real, dimension(klon), intent(IN) :: u1_lay, v1_lay + real, dimension(klon), intent(IN) :: temp_air + real, dimension(klon), intent(IN) :: epot_air + real, dimension(klon), intent(IN) :: petAcoef + real, dimension(klon), intent(IN) :: petBcoef + real, dimension(klon), intent(IN) :: sollw, sollwdown, swnet, swdown + real, dimension(klon), intent(IN) :: albedo + real, dimension(klon), intent(IN) :: tsurf, pkh1, p1lay + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol,fder + real, dimension(klon), intent(IN) :: taux, tauy +!! PB ajout pour soil + logical :: soil_model + integer :: nsoilmx + REAL, DIMENSION(klon, nsoilmx) :: tsoil + REAL, dimension(klon) :: soilcap + REAL, dimension(klon) :: soilflux +! Parametres de sortie + real, dimension(klon), intent(OUT):: fluxsens + real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new + real, dimension(klon), intent(OUT):: dflux_s + +! Local + character (len = 20),save :: modname = 'interfsurf_hq' + character (len = 80) :: abort_message + integer, save :: error + integer :: ii, index + logical,save :: check = .false. + real, dimension(klon):: cal, beta, capsol + real, dimension(klon):: tsurf_temp, zcp + INTEGER,dimension(1) :: iloc + INTEGER :: isize + real, dimension(klon):: fder_prev + + if (check) write(*,*) 'Entree ', modname + +! Initialisations diverses +! + cal = 999999. ; beta = 999999. ; capsol = 999999. + alb_new = albedo + tsurf_new = 999999. + +! ADAPTATION GCM POUR CP(T) + do ii=1,klon + zcp(ii)=cpdet(tsurf(ii)) + enddo + + IF (soil_model) THEN + CALL soil(dtime, knon, tsurf, tsoil,soilcap, soilflux) + cal(1:knon) = zcp(1:knon) / soilcap(1:knon) +! for tests: +! call writefield_phy('interfsurf_hq_zcp',zcp,1) +! call writefield_phy('interfsurf_hq_cal',cal,1) +! call writefield_phy('interfsurf_hq_soilcap',soilcap,1) +! print*,"DIAGNOSTIC SOIL" +! print*,"soilcap=",soilcap +! print*,"soilflux=",soilflux +! print*,"radsol=",radsol(knon/2) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + ELSE +! abort_message = "PAS DE MODELE DE SOL: CALCUL SOILCAP!!" +! call abort_gcm(modname,abort_message,1) +! VENUS: Valeur pour inertie = 200: + soilcap = 14735. + print*,"PAS DE MODELE DE SOL, soilcap=",soilcap + cal(1:knon) = zcp(1:knon) / soilcap(1:knon) + ENDIF +! ADAPTATION GCM POUR CP(T) + CALL calcul_fluxs( klon, knon, dtime, & + & tsurf, zcp, pkh1, p1lay, cal, beta, tq_cdrag, & + & radsol, temp_air, u1_lay, v1_lay, & + & petAcoef, petBcoef, & + & tsurf_new, fluxsens, dflux_s ) + + END SUBROUTINE interfsurf_hq + +! +!######################################################################### +! + SUBROUTINE calcul_fluxs( klon, knon, dtime, & +! ADAPTATION GCM POUR CP(T) + & tsurf, zcp, pkh1, p1lay, cal, beta, coef1lay, & + & radsol, t1lay, u1lay, v1lay, & + & petAcoef, petBcoef, & + & tsurf_new, fluxsens, dflux_s) + + use write_field_phy + use cpdet_phy_mod, only: t2tpot, tpot2t + + IMPLICIT none + +! Cette routine calcule les fluxs en h a l'interface et eventuellement +! une temperature de surface (au cas ou ok_veget = false) +! +! L. Fairhead 4/2000 +! +! input: +! knon nombre de points a traiter +! tsurf temperature de surface +! zcp Cp(Tsurf) +! pkh1 fct Exner à la surface: RCPD*(paprs(1)/preff)**RKAPPA +! p1lay pression 1er niveau (milieu de couche) +! cal capacite calorifique du sol +! beta evap reelle +! coef1lay coefficient d'echange +! petAcoef coeff. A de la resolution de la CL pour t +! petBcoef coeff. B de la resolution de la CL pour t +! radsol rayonnement net aus sol (LW + SW) +! +! output: +! tsurf_new temperature au sol +! fluxsens flux de chaleur sensible +! dflux_s derivee du flux de chaleur sensible / Ts +! + +! Parametres d'entree + integer, intent(IN) :: knon, klon + real , intent(IN) :: dtime + real, dimension(klon), intent(IN) :: petAcoef + real, dimension(klon), intent(IN) :: petBcoef +! ADAPTATION GCM POUR CP(T) + real, dimension(klon), intent(IN) :: tsurf,pkh1,zcp + real, dimension(klon), intent(IN) :: p1lay, cal, beta, coef1lay + real, dimension(klon), intent(IN) :: radsol + real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay + +! Parametres sorties + real, dimension(klon), intent(OUT):: tsurf_new, fluxsens + real, dimension(klon), intent(OUT):: dflux_s + +! Variables locales + integer :: i + real, dimension(klon) :: zx_mh, zx_nh, zx_oh + real, dimension(klon) :: zx_coef + real, dimension(klon) :: ztetasurf,ztetasurf_new + real, dimension(klon) :: zx_k1 + real, dimension(klon) :: zx_q_0 , d_ts + real :: zdelta, zcvm5, zcor +! + logical, save :: check = .false. + character (len = 20) :: modname = 'calcul_fluxs' + character (len = 80) :: abort_message + logical,save :: first = .true.,second=.false. + + if (check) write(*,*)'Entree ', modname + + IF (check) THEN + WRITE(*,*)' radsol (min, max)' & + & , MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon)) + CALL flush(6) + ENDIF + +! +! Initialisation +! + fluxsens=0. + dflux_s = 0. +! + DO i = 1, knon + + zx_coef(i) = coef1lay(i) & + & * SQRT(u1lay(i)**2+v1lay(i)**2) & + & * p1lay(i)/(RD*t1lay(i)) + + ENDDO + + +! === Calcul de la temperature de surface === +! +! MODIF VENUS: +! Le calcul se fait en temperature potentielle + + call t2tpot(knon,tsurf,ztetasurf,pkh1) + + do i = 1, knon + zx_k1(i) = zx_coef(i) + enddo + + + do i = 1, knon + +! H + zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime) + zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i) +! Derives des flux dF/d(teta)s: + zx_nh(i) = - (zx_k1(i) * zcp(i))/ zx_oh(i) +! Derives des flux dF/dTs (W m-2 K-1): version Terre +! zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i) + +! Tsurface Version Terre +! +! tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * & +! & (radsol(i) + zx_mh(i)) & +! & + dif_grnd(i) * t_grnd * dtime)/ & +! & ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * & +! & zx_nh(i) & +! & + dtime * dif_grnd(i)) +! +! d_ts(i) = tsurf_new(i) - tsurf(i) +! fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i) +! Derives des flux dF/dTs (W m-2 K-1): +! dflux_s(i) = zx_nh(i) + +! MODIF VENUS : on vire dif_grnd (=0) et t_grnd +! et on travaille en teta + + ztetasurf_new(i) = (ztetasurf(i) + cal(i)/zcp(i) * dtime * & + & (radsol(i) + zx_mh(i)) & + & ) / & + & ( 1. - cal(i)/zcp(i) * dtime * & + & zx_nh(i) ) + ENDDO + + call tpot2t(knon,ztetasurf_new,tsurf_new,pkh1) + + do i = 1, knon + d_ts(i) = tsurf_new(i) - tsurf(i) + fluxsens(i) = zx_mh(i) + zx_nh(i) * ztetasurf_new(i) +! Derives des flux dF/dTs (W m-2 K-1): + dflux_s(i) = zx_nh(i)*ztetasurf(i)/tsurf(i) + ENDDO + +! for tests: write output fields... +! call writefield_phy('calcul_fluxs_d_ts',d_ts,1) +! call writefield_phy('calcul_fluxs_fluxsens',fluxsens,1) +! call writefield_phy('calcul_fluxs_dflux_s',dflux_s,1) + + END SUBROUTINE calcul_fluxs +! +!######################################################################### +! + END MODULE interface_surf Index: trunk/LMDZ.TITAN.old/libf/phytitan/interp_vert.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/interp_vert.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/interp_vert.F (revision 1643) @@ -0,0 +1,84 @@ +c****************************************************** + SUBROUTINE interp_vert(varo,varn,lmo,lmn,apo,bpo, + & ap,bp,ps,Nhoriz) +c +c interpolation lineaire pour passer +c a une nouvelle discretisation verticale pour +c les variables de GCM +c Francois Forget (01/1995) +c Modif pour coordonnees hybrides FF (03/2003) +c modif pour entrees avec ap et bp au lieu de aps et bps (SL,2007) +c********************************************************** + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + + integer lmo ! dimensions ancienne couches (input) + integer lmn ! dimensions nouvelle couches (input) + + real apo(lmo+1),bpo(lmo+1)! anciennes coord hybrides interlayer (input) + real ap(lmn+1), bp(lmn+1)! nouvelles coord hybrides (interlayer) (input) + + integer Nhoriz ! nombre de point horizontale (input) + real ps(nhoriz) !pression de surface (input) + + real varo(Nhoriz,lmo) ! var dans l''ancienne grille (input) + real varn(Nhoriz,lmn) ! var dans la nouvelle grille (output) + +c Autres variables +c """""""""""""""" + integer n, ln ,lo + real coef + REAL sigmo(lmo) ! niveau sigma des variables dans les anciennes coord + REAL sigmn(lmn) ! niveau sigma des variables dans les nouvelles coord + + real apso(lmo),bpso(lmo)! anciennes coord hybrides midlayer + real aps(lmn), bps(lmn)! nouvelles coord hybrides (midlayer) + +c run +c ==== + + do ln=1,lmn + aps(ln)=(ap(ln)+ap(ln+1))/2. + bps(ln)=(bp(ln)+bp(ln+1))/2. + end do + do lo=1,lmo + apso(lo)=(apo(lo)+apo(lo+1))/2. + bpso(lo)=(bpo(lo)+bpo(lo+1))/2. + end do + + do n=1,Nhoriz + + do ln=1,lmn + sigmn(ln)=aps(ln)/ps(n)+bps(ln) + end do + do lo=1,lmo + sigmo(lo)=apso(lo)/ps(n)+bpso(lo) + end do + + do ln=1,lmn + if (sigmn(ln).ge.sigmo(1))then + varn(n,ln) = varo(n,1) + else if (sigmn(ln).le.sigmo(lmo)) then + varn(n,ln) = varo(n,lmo) + else + do lo =1,lmo-1 + if ( (sigmn(ln).le.sigmo(lo)).and. + & (sigmn(ln).gt.sigmo(lo+1)) )then + coef = (sigmn(ln)-sigmo(lo))/(sigmo(lo+1)-sigmo(lo)) + varn(n,ln)=varo(n,lo) +coef*(varo(n,lo+1)-varo(n,lo)) + end if + end do + end if + end do + + end do + + + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/iophy.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/iophy.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/iophy.F90 (revision 1643) @@ -0,0 +1,445 @@ +! +! $Header$ +! +module iophy + +! abd REAL,private,allocatable,dimension(:),save :: io_lat +! abd REAL,private,allocatable,dimension(:),save :: io_lon + REAL,allocatable,dimension(:),save :: io_lat + REAL,allocatable,dimension(:),save :: io_lon + INTEGER, save :: phys_domain_id + INTEGER, save :: npstn + INTEGER, allocatable, dimension(:), save :: nptabij + + INTERFACE histwrite_phy + MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy + END INTERFACE + + INTERFACE histbeg_phy_all + MODULE PROCEDURE histbeg_phy,histbeg_phy_points + END INTERFACE + + +contains + + subroutine init_iophy_new(rlat,rlon) + USE dimphy, only: klon + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo + USE ioipsl + implicit none + real,dimension(klon),intent(in) :: rlon ! longitudes, in degrees + real,dimension(klon),intent(in) :: rlat ! latitudes, in degrees + + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + INTEGER :: i + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +!$OMP MASTER + ALLOCATE(io_lat(nbp_lat)) + IF (klon_glo == 1) THEN + io_lat(1)=rlat_glo(1) + ELSE + io_lat(1)=rlat_glo(1) + io_lat(nbp_lat)=rlat_glo(klon_glo) + DO i=2,nbp_lat-1 + io_lat(i)=rlat_glo(2+(i-2)*nbp_lon) + ENDDO + ENDIF + + ALLOCATE(io_lon(nbp_lon)) + IF (klon_glo == 1) THEN + io_lon(1)=rlon_glo(1) + ELSE + io_lon(1:nbp_lon)=rlon_glo(2:nbp_lon+1) + ENDIF + + ddid=(/ 1,2 /) + dsg=(/ nbp_lon, nbp_lat /) + dsl=(/ nbp_lon, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ nbp_lon, jj_end /) + dhs=(/ ii_begin-1,0 /) + IF (mpi_rank==mpi_size-1) THEN + dhe=(/0,0/) + ELSE + dhe=(/ nbp_lon-ii_end,0 /) + ENDIF + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy_new + + subroutine init_iophy(lat,lon) + USE dimphy + USE mod_phys_lmdz_para + use ioipsl, only: flio_dom_set + USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat + implicit none + real,dimension(nbp_lon),intent(in) :: lon + real,dimension(nbp_lat),intent(in) :: lat + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + +!$OMP MASTER + allocate(io_lat(nbp_lat)) + io_lat(:)=lat(:) + allocate(io_lon(nbp_lon)) + io_lon(:)=lon(:) + + ddid=(/ 1,2 /) + dsg=(/ nbp_lon, nbp_lat /) + dsl=(/ nbp_lon, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ nbp_lon, jj_end /) + dhs=(/ ii_begin-1,0 /) + if (mpi_rank==mpi_size-1) then + dhe=(/0,0/) + else + dhe=(/ nbp_lon-ii_end,0 /) + endif + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy + + subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day) + USE mod_phys_lmdz_para, only: jj_begin, jj_end, jj_nb, is_sequential + USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat + use ioipsl, only: histbeg + use write_field + implicit none + + character*(*), intent(IN) :: name + integer, intent(in) :: itau0 + real,intent(in) :: zjulian + real,intent(in) :: dtime + integer,intent(out) :: nhori + integer,intent(out) :: nid_day + +!$OMP MASTER + if (is_sequential) then + call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day) + else + call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id) + endif +!$OMP END MASTER + + end subroutine histbeg_phy + + subroutine histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, & + plon,plat,plon_bounds,plat_bounds, & + nname,itau0,zjulian,dtime,nnhori,nnid_day) + USE dimphy, only: klon + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz, only: klon_glo, nbp_lon, nbp_lat + use ioipsl, only: histbeg + + implicit none + + real,dimension(klon),intent(in) :: rlon + real,dimension(klon),intent(in) :: rlat + integer, intent(in) :: itau0 + real,intent(in) :: zjulian + real,intent(in) :: dtime + integer, intent(in) :: pim + integer, intent(out) :: nnhori + character(len=20), intent(in) :: nname + INTEGER, intent(out) :: nnid_day + integer :: i + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + INTEGER, DIMENSION(pim), intent(in) :: tabij + REAL,dimension(pim), intent(in) :: plat, plon + INTEGER,dimension(pim), intent(in) :: ipt, jpt + REAL,dimension(pim,2), intent(out) :: plat_bounds, plon_bounds + + INTEGER, SAVE :: tabprocbeg, tabprocend +!$OMP THREADPRIVATE(tabprocbeg, tabprocend) + INTEGER :: ip + INTEGER, PARAMETER :: nip=1 + INTEGER :: npproc + REAL, allocatable, dimension(:) :: npplat, npplon + REAL, allocatable, dimension(:,:) :: npplat_bounds, npplon_bounds + REAL, dimension(nbp_lon,nbp_lat) :: zx_lon, zx_lat + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +!$OMP MASTER + DO i=1,pim + +! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) + + plon_bounds(i,1)=rlon_glo(tabij(i)-1) + plon_bounds(i,2)=rlon_glo(tabij(i)+1) + if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN + if(rlon_glo(tabij(i)).GE.0.) THEN + plon_bounds(i,2)=-1*plon_bounds(i,2) + endif + endif + if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN + if(rlon_glo(tabij(i)).LE.0.) THEN + plon_bounds(i,2)=-1*plon_bounds(i,2) + endif + endif +! + IF ( tabij(i).LE.nbp_lon) THEN + plat_bounds(i,1)=rlat_glo(tabij(i)) + ELSE + plat_bounds(i,1)=rlat_glo(tabij(i)-nbp_lon) + ENDIF + plat_bounds(i,2)=rlat_glo(tabij(i)+nbp_lon) +! +! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2) +! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2) +! + ENDDO + if (is_sequential) then + + npstn=pim + IF(.NOT. ALLOCATED(nptabij)) THEN + ALLOCATE(nptabij(pim)) + ENDIF + DO i=1,pim + nptabij(i)=tabij(i) + ENDDO + + CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon) + if ((nbp_lon*nbp_lat).gt.1) then + DO i = 1, nbp_lon + zx_lon(i,1) = rlon_glo(i+1) + zx_lon(i,nbp_lat) = rlon_glo(i+1) + ENDDO + endif + CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat_glo,zx_lat) + + DO i=1,pim +! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) + + plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i)) + plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i)) + + if (ipt(i).EQ.1) then + plon_bounds(i,1)=zx_lon(nbp_lon,jpt(i)) + plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i)) + endif + + if (ipt(i).EQ.nbp_lon) then + plon_bounds(i,2)=360.+zx_lon(1,jpt(i)) + endif + + plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1) + plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1) + + if (jpt(i).EQ.1) then + plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001 + plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001 + endif + + if (jpt(i).EQ.nbp_lat) then + plat_bounds(i,1)=zx_lat(ipt(i),nbp_lat)+0.001 + plat_bounds(i,2)=zx_lat(ipt(i),nbp_lat)-0.001 + endif +! +! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2) +! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2) +! + ENDDO +! print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day + call histbeg(nname,pim,plon,plon_bounds, & + plat,plat_bounds, & + itau0, zjulian, dtime, nnhori, nnid_day) + else + npproc=0 + DO ip=1, pim + tabprocbeg=klon_mpi_begin + tabprocend=klon_mpi_end + IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN + npproc=npproc+1 + npstn=npproc + ENDIF + ENDDO +! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn + IF(.NOT. ALLOCATED(nptabij)) THEN + ALLOCATE(nptabij(npstn)) + ALLOCATE(npplon(npstn), npplat(npstn)) + ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2)) + ENDIF + npproc=0 + DO ip=1, pim + IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN + npproc=npproc+1 + nptabij(npproc)=tabij(ip) +! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, & +! plon(ip),plat(ip),tabij(ip) + npplon(npproc)=plon(ip) + npplat(npproc)=plat(ip) + npplon_bounds(npproc,1)=plon_bounds(ip,1) + npplon_bounds(npproc,2)=plon_bounds(ip,2) + npplat_bounds(npproc,1)=plat_bounds(ip,1) + npplat_bounds(npproc,2)=plat_bounds(ip,2) +!!! +!!! print qui sert a reordonner les points stations selon l'ordre CFMIP +!!! ne pas enlever + print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip) +!!! + ENDIF + ENDDO + call histbeg(nname,npstn,npplon,npplon_bounds, & + npplat,npplat_bounds, & + itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id) + endif +!$OMP END MASTER + + end subroutine histbeg_phy_points + + subroutine histwrite2d_phy(nid,lpoint,name,itau,field) + USE dimphy, only: klon + USE mod_phys_lmdz_para + USE ioipsl, only: histwrite + USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat + implicit none + + integer,intent(in) :: nid + logical,intent(in) :: lpoint + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(:),intent(in) :: field + REAL,dimension(klon_mpi) :: buffer_omp + INTEGER, allocatable, dimension(:) :: index2d + REAL :: Field2d(nbp_lon,jj_nb) + + integer :: ip + real,allocatable,dimension(:) :: fieldok + + IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1) + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,Field2d) + if(.NOT.lpoint) THEN + ALLOCATE(index2d(nbp_lon*jj_nb)) + ALLOCATE(fieldok(nbp_lon*jj_nb)) + CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d) + else + ALLOCATE(fieldok(npstn)) + ALLOCATE(index2d(npstn)) + + if(is_sequential) then +! klon_mpi_begin=1 +! klon_mpi_end=klon + DO ip=1, npstn + fieldok(ip)=buffer_omp(nptabij(ip)) + ENDDO + else + DO ip=1, npstn +! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip) + IF(nptabij(ip).GE.klon_mpi_begin.AND. & + nptabij(ip).LE.klon_mpi_end) THEN + fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1) + ENDIF + ENDDO + endif + CALL histwrite(nid,name,itau,fieldok,npstn,index2d) +! + endif + deallocate(index2d) + deallocate(fieldok) +!$OMP END MASTER + end subroutine histwrite2d_phy + + subroutine histwrite3d_phy(nid,lpoint,name,itau,field) + USE dimphy, only: klon + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat + use ioipsl, only: histwrite + implicit none + + integer,intent(in) :: nid + logical,intent(in) :: lpoint + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(:,:),intent(in) :: field ! --> field(klon,:) + REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp + REAL :: Field3d(nbp_lon,jj_nb,size(field,2)) + INTEGER :: ip, n, nlev + INTEGER, ALLOCATABLE, dimension(:) :: index3d + real,allocatable, dimension(:,:) :: fieldok + + IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1) + nlev=size(field,2) + +! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn + +! DO ip=1, npstn +! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip) +! ENDDO + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,field3d) + if(.NOT.lpoint) THEN + ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) + ALLOCATE(fieldok(nbp_lon*jj_nb,nlev)) + CALL histwrite(nid,name,itau,Field3d,nbp_lon*jj_nb*nlev,index3d) + else + nlev=size(field,2) + ALLOCATE(index3d(npstn*nlev)) + ALLOCATE(fieldok(npstn,nlev)) + + if(is_sequential) then +! klon_mpi_begin=1 +! klon_mpi_end=klon + DO n=1, nlev + DO ip=1, npstn + fieldok(ip,n)=buffer_omp(nptabij(ip),n) + ENDDO + ENDDO + else + DO n=1, nlev + DO ip=1, npstn + IF(nptabij(ip).GE.klon_mpi_begin.AND. & + nptabij(ip).LE.klon_mpi_end) THEN + fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n) + ENDIF + ENDDO + ENDDO + endif + CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d) + endif + deallocate(index3d) + deallocate(fieldok) +!$OMP END MASTER + end subroutine histwrite3d_phy + +end module iophy Index: trunk/LMDZ.TITAN.old/libf/phytitan/iostart.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/iostart.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/iostart.F90 (revision 1643) @@ -0,0 +1,508 @@ +MODULE iostart + +PRIVATE + INTEGER,SAVE :: nid_start + INTEGER,SAVE :: nid_restart + + INTEGER,SAVE :: idim1,idim2,idim3,idim4 + INTEGER,PARAMETER :: length=100 + + INTERFACE get_field + MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3 + END INTERFACE get_field + + INTERFACE get_var + MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3 + END INTERFACE get_var + + INTERFACE put_field + MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3 + END INTERFACE put_field + + INTERFACE put_var + MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3 + END INTERFACE put_var + + PUBLIC get_field,get_var,put_field,put_var + PUBLIC open_startphy,close_startphy,open_restartphy,close_restartphy + +CONTAINS + + SUBROUTINE open_startphy(filename) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start) + IF (ierr.NE.NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + ENDIF + + END SUBROUTINE open_startphy + + SUBROUTINE Close_startphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_start) + ENDIF + + END SUBROUTINE close_startphy + + + FUNCTION Inquire_Field(Field_name) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + LOGICAL :: inquire_field + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + IF (ierr==NF90_NOERR) THEN + Inquire_field=.TRUE. + ELSE + Inquire_field=.FALSE. + ENDIF + ENDIF + + CALL bcast(Inquire_field) + + END FUNCTION Inquire_Field + + + SUBROUTINE Get_Field_r1(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,1,found) + ELSE + CALL Get_field_rgen(field_name,field,1) + ENDIF + + END SUBROUTINE Get_Field_r1 + + SUBROUTINE Get_Field_r2(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)) + ENDIF + + + END SUBROUTINE Get_Field_r2 + + SUBROUTINE Get_Field_r3(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3)) + ENDIF + + END SUBROUTINE Get_Field_r3 + + SUBROUTINE Get_field_rgen(field_name,field,field_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + INTEGER :: field_size + REAL :: field(klon,field_size) + LOGICAL,OPTIONAL :: found + + REAL :: field_glo(klon_glo,field_size) + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + + IF (ierr==NF90_NOERR) THEN + CALL body(field_glo) + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL scatter(field_glo,field) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent' + CALL abort + ENDIF + ENDIF + + + CONTAINS + + SUBROUTINE body(field_glo) + REAL :: field_glo(klon_glo*field_size) + ierr=NF90_GET_VAR(nid_start,varid,field_glo) + IF (ierr/=NF90_NOERR) THEN + ! La variable exist dans le fichier mais la lecture a echouee. + PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>' + + IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN + ! Essaye de lire le variable sur surface uniqument, comme fait avant + field_glo(:)=0. + ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo)) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>' + CALL abort + ELSE + PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero' + END IF + ELSE + CALL abort + ENDIF + ENDIF + + END SUBROUTINE body + + END SUBROUTINE Get_field_rgen + + + SUBROUTINE get_var_r0(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + REAL :: varout(1) + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,varout,size(varout),found) + ELSE + CALL Get_var_rgen(var_name,varout,size(varout)) + ENDIF + var=varout(1) + + END SUBROUTINE get_var_r0 + + SUBROUTINE get_var_r1(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r1 + + SUBROUTINE get_var_r2(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(OUT) :: var(:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r2 + + SUBROUTINE get_var_r3(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:,:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r3 + + SUBROUTINE Get_var_rgen(var_name,var,var_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: var_name + INTEGER :: var_size + REAL :: var(var_size) + LOGICAL,OPTIONAL :: found + + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,var_name,varid) + + IF (ierr==NF90_NOERR) THEN + ierr=NF90_GET_VAR(nid_start,varid,var) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>' + CALL abort + ENDIF + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL bcast(var) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente' + CALL abort + ENDIF + ENDIF + + END SUBROUTINE Get_var_rgen + + + SUBROUTINE open_restartphy(filename) + USE netcdf + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE dimphy + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart) + IF (ierr/=NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + + ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemarrage physique") + + ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1) + ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2) + ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3) + ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4) + + ierr = NF90_ENDDEF(nid_restart) + ENDIF + + END SUBROUTINE open_restartphy + + SUBROUTINE close_restartphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_restart) + ENDIF + + END SUBROUTINE close_restartphy + + + SUBROUTINE put_field_r1(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:) + + CALL put_field_rgen(field_name,title,field,1) + + END SUBROUTINE put_field_r1 + + SUBROUTINE put_field_r2(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)) + + END SUBROUTINE put_field_r2 + + SUBROUTINE put_field_r3(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3)) + + END SUBROUTINE put_field_r3 + + SUBROUTINE put_field_rgen(field_name,title,field,field_size) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: field_size + REAL,INTENT(IN) :: field(klon,field_size) + + REAL :: field_glo(klon_glo,field_size) + INTEGER :: ierr + INTEGER :: nvarid + INTEGER :: idim + + + CALL gather(field,field_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (field_size==1) THEN + idim=idim2 + ELSE IF (field_size==klev) THEN + idim=idim3 + ELSE IF (field_size==klevp1) THEN + idim=idim4 + ELSE + PRINT *, "erreur phyredem : probleme de dimension" + CALL ABORT + ENDIF + + ierr = NF90_REDEF (nid_restart) +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid) +#endif + IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/))) + ENDIF + + END SUBROUTINE put_field_rgen + + SUBROUTINE put_var_r0(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var + REAL :: varin(1) + + varin(1)=var + + CALL put_var_rgen(var_name,title,varin,size(varin)) + + END SUBROUTINE put_var_r0 + + + SUBROUTINE put_var_r1(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r1 + + SUBROUTINE put_var_r2(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r2 + + SUBROUTINE put_var_r3(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r3 + + SUBROUTINE put_var_rgen(var_name,title,var,var_size) + USE netcdf + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: var_size + REAL,INTENT(IN) :: var(var_size) + + INTEGER :: ierr + INTEGER :: nvarid + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (var_size/=length) THEN + PRINT *, "erreur phyredem : probleme de dimension" + CALL abort + ENDIF + + ierr = NF90_REDEF (nid_restart) + +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid) +#endif + IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + + ierr = NF90_PUT_VAR(nid_restart,nvarid,var) + + ENDIF + + END SUBROUTINE put_var_rgen + +END MODULE iostart Index: trunk/LMDZ.TITAN.old/libf/phytitan/itemps.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/itemps.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/itemps.h (revision 1643) @@ -0,0 +1,25 @@ +!--------------------------------------------------------------------c +! itemps.h : variable de temps d'executions. c +!--------------------------------------------------------------------c + real ttphys ! tps exec de la physique + real ttmuphys ! tps exec de la microphysique + real tthaze ! tps exec de la brume + real ttcclds ! tps exec CONDENSATION nuages + real ttsclds ! tps exec SEDIMENTATION nuages + real ttdynt ! tps exec dyn tout confondu (comprend physique) + real ttphytra ! tps exec phytrac + real ttrad ! tps exec TR + real ttadvtr ! tps exec advection des traceurs dans la dynamique + + common /itimes/ttdynt,ttphys,ttphytra,ttrad, & + & ttmuphys,tthaze,ttcclds,ttsclds,ttadvtr + + +! ---- variables locales a chaque routines utilisant itemps.h + real tt0 ! tps de demarage de la routine + real ttt0 ! tps de demarage de la routine + real tttt0 ! tps de demarage de la routine + real tt1 ! tps d'EXECUTION de la routine. + real ttt1 ! tps d'EXECUTION de la routine. + real tttt1 ! tps d'EXECUTION de la routine. + Index: trunk/LMDZ.TITAN.old/libf/phytitan/lell.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/lell.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/lell.F (revision 1643) @@ -0,0 +1,280 @@ + SUBROUTINE LELL(NLEVEL,Z,RHCH4L,FH2L,FARGON,TEMP,PRESS,DEN,XMU, + & CH4,H2,XN2,AR,IPRINT) +C THIS SUBROUTINE SETS UP THE INTITAL ATMOSPHERIC PROFILE FOR TITAN +C BASED ON THE LELLOUCH AT AL DATA. THE ROUTINE STARTS WITH INPUTS +C INPUTS: +C NLEVEL: NUMBER OF ALTITUDE LEVELS, J=1 IS AT THE TOP +C P PRESS GRID IN BARS +C +C ASSUMES: FARGON = 0 +C : FH2 = 0.03 +C +C OUTPUTS: RHCH4 AT SURFACE +C AND AT EACH LEVEL (NOT LAYER AVERAGES) +C TEMP (K), PRESS(BARS), DEN(CM-3), XMU = MEAN MOLECUALR WEIGHT +C CH4, H2, XN2, AR ARE THE NUMBER MIXING RATIOS OF THE GASES +C +C DATA: IS THE LELLOUCH ET AL VALUES DENOTED BY __LE(J) +C +C NEW VERSION FOR GCM : Z E [0,1200] + INTEGER ITIME + DIMENSION Z(NLEVEL),TEMP(NLEVEL),PRESS(NLEVEL), + $ DEN(NLEVEL),XMU(NLEVEL) + DIMENSION CH4(NLEVEL),H2(NLEVEL),XN2(NLEVEL),AR(NLEVEL) +C + DIMENSION ZLE(148), XN2LE(148), CH4LE(148), TLE(148), PLE(148), + & DLE(148), XMULE(148), DENMLE(148) + + save ZLE,XN2LE,CH4LE,TLE,PLE,DLE,XMULE,DENMLE + save itime + data itime/0/ +C +C + DATA ZLE/ + & 1265., 1215., 1165., 1116., 1050., 1000., 950.0, 900.0, 880.0, + & 820.0, 800.0, 760.0, 700.0, 675.0, 650.0, 625.0, 600.0, 575.0, + & 550.0, 525.0, 500.0, 475.0, 450.0, 435.0, 420.0, 410.0, 400.0, + & 390.0, 380.0, 350.0, 340.0, 330.0, 320.0, 310.0, 300.0, 280.0, + & 260.0, 250.0, 240.0, 230.0, 220.0, 210.0, + & 200.0, 198.0, 196.0, 194.0, 192.0, 190.0, 188.0, 186.0, 184.0, + & 182.0, 180.0, 178.0, 176.0, 174.0, 172.0, 170.0, 168.0, 166.0, + & 164.0, 162.0, 160.0, 158.0, 156.0, 154.0, 152.0, 150.0, 148.0, + & 146.0, 144.0, 142.0, 140.0, 138.0, 136.0, 134.0, 132.0, 130.0, + & 128.0, 126.0, 124.0, 122.0, 120.0, 118.0, 116.0, 114.0, 112.0, + & 110.0, 108.0, 106.0, 104.0, 102.0, 100.0, 98.0, 96.0, 94.0, + & 92.0, 90.0, 88.0, 86.0, 84.0, 82.0, 80.0, 78.0, 76.0, + & 74.0, 72.0, 70.0, 68.0, 66.0, 64.0, 62.0, 60.0, 58.0, + & 56.0, 54.0, 52.0, 50.0, 48.0, 46.0, 44.0, 42.0, 40.0, + & 38.0, 36.0, 34.0, 32.0, 30.0, 28.0, 26.0, 24.0, 22.0, + & 20.0, 18.0, 16.0, 14.0, 12.0, 10.0, 8.0, 6.0, 5.0, + & 4.0, 3.0, 2.0, 1.5, 1.0, 0.5, 0.0/ +! N2 MIXING RATIO + DATA XN2LE/ + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.984, 0.983, 0.983, 0.982, 0.980, 0.979, + & 0.977, 0.974, 0.971, 0.966, 0.960, 0.955, 0.945, 0.935, 0.926, + & 0.920, 0.920, 0.920, 0.920, 0.920, 0.920, 0.920/ +! CH4 MIXING RATIO + DATA CH4LE/ + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.016, 0.017, 0.017, 0.018, 0.020, 0.021, + & 0.023, 0.026, 0.029, 0.034, 0.040, 0.045, 0.055, 0.065, 0.074, + & 0.080, 0.080, 0.080, 0.080, 0.080, 0.080, 0.080/ +! TEMPERATURE IN k + DATA TLE/ + & 183.0, 181.0, 178.0, 174.7, 169.0, 164.0, 158.0, 150.0, 147.0, + & 136.0, 135.0, 137.0, 143.0, 146.5, 150.0, 154.5, 159.0, 163.5, + & 166.5, 169.0, 171.1, 172.8, 174.3, 175.1, 175.6, 175.9, 176.0, + & 176.0, 175.9, 175.8, 175.7, 175.6, 175.5, 175.4, 175.3, 175.2, + & 175.1, 175.0, 174.9, 174.8, 174.6, 174.4, + & 174.0, 173.9, 173.8, 173.6, 173.4, 173.2, 173.0, 172.9, 172.7, + & 172.5, 172.4, 172.2, 172.0, 171.8, 171.6, 171.4, 171.2, 171.0, + & 170.8, 170.4, 169.9, 169.5, 169.0, 168.5, 167.9, 167.4, 166.7, + & 166.0, 165.3, 164.5, 163.7, 163.0, 162.4, 161.8, 161.2, 160.5, + & 159.6, 158.6, 157.5, 156.3, 155.3, 154.3, 153.4, 152.6, 151.9, + & 151.0, 150.1, 149.0, 147.8, 146.5, 145.1, 143.7, 142.1, 140.6, + & 139.1, 137.6, 135.8, 133.8, 131.5, 128.8, 125.8, 122.7, 119.7, + & 116.6, 111.9, 106.1, 100.5, 92.6, 85.9, 80.9, 77.6, 75.4, + & 73.8, 72.8, 72.2, 71.7, 71.5, 71.4, 71.2, 71.1, 71.1, + & 71.2, 71.4, 71.5, 71.8, 72.3, 73.1, 73.9, 74.7, 75.7, + & 76.7, 78.0, 79.2, 80.6, 82.1, 83.6, 85.5, 87.3, 88.5, + & 89.5, 90.5, 91.5, 92.1, 92.9, 93.7, 94.5/ +! & 89.5, 90.5, 91.5, 92.1, 92.7, 93.3, 93.9/ +! PRESSURE IN MILLIBARS + DATA PLE/ + & 8.08e-09, 1.39e-08, 2.45e-08, 4.41e-08, 1.03e-07, 2.04e-07, + & 4.27e-07, 9.44e-07, 1.32e-06, 3.92e-06, 5.77e-06, 1.26e-05, + & 4.11e-05, 6.68e-05, 1.08e-04, 1.75e-04, 2.80e-04, 4.46e-04, + & 7.08e-04, 1.12e-03, 1.78e-03, 2.84e-03, 4.54e-03, 6.03e-03, + & 8.01e-03, 9.70e-03, 1.18e-02, 1.43e-02, 1.73e-02, 3.13e-02, + & 3.83e-02, 4.69e-02, 5.74e-02, 7.05e-02, 8.66e-02, 1.32e-01, + & 2.01e-01, 2.49e-01, 3.09e-01, 3.84e-01, 4.78e-01, 5.96e-01, ! + & 7.59E-01, 7.98E-01, 8.37E-01, 8.77E-01, 9.20E-01, 9.64E-01, + & 1.01E+00, 1.06E+00, 1.11E+00, 1.16E+00, 1.22E+00, 1.28E+00, + & 1.35E+00, 1.41E+00, 1.48E+00, 1.55E+00, 1.63E+00, 1.71E+00, + & 1.79E+00, 1.88E+00, 1.97E+00, 2.07E+00, 2.17E+00, 2.29E+00, + & 2.40E+00, 2.52E+00, 2.65E+00, 2.78E+00, 2.93E+00, 3.08E+00, + & 3.24E+00, 3.41E+00, 3.59E+00, 3.78E+00, 3.90E+00, 4.19E+00, + & 4.42E+00, 4.66E+00, 4.91E+00, 5.19E+00, 5.48E+00, 5.78E+00, + & 6.10E+00, 6.45E+00, 6.82E+00, 7.22E+00, 7.63E+00, 8.08E+00, + & 8.56E+00, 9.06E+00, 9.61E+00, 1.02E+01, 1.08E+01, 1.15E+01, + & 1.22E+01, 1.30E+01, 1.38E+01, 1.47E+01, 1.57E+01, 1.68E+01, + & 1.80E+01, 1.93E+01, 2.07E+01, 2.23E+01, 2.40E+01, 2.60E+01, + & 2.83E+01, 3.10E+01, 3.42E+01, 3.79E+01, 4.23E+01, 4.75E+01, + & 5.34E+01, 6.01E+01, 6.79E+01, 7.67E+01, 8.67E+01, 9.81E+01, + & 1.11E+02, 1.26E+02, 1.42E+02, 1.61E+02, 1.83E+02, 2.07E+02, + & 2.35E+02, 2.65E+02, 3.00E+02, 3.40E+02, 3.83E+02, 4.32E+02, + & 4.87E+02, 5.47E+02, 6.14E+02, 6.88E+02, 7.70E+02, 8.59E+02, + & 9.57E+02, 1.06E+03, 1.12E+03, 1.18E+03, 1.24E+03, 1.30E+03, + & 1.34E+03, 1.38E+03, 1.43E+03, 1.48E+03/ +! & 1.34E+03, 1.37E+03, 1.40E+03, 1.44E+03/ +! NUMBER DENSITY + DATA DLE/ + & 3.20e+08, 5.55e+08, 9.96e+08, 1.83e+09, 4.40e+09, 9.03e+09, + & 1.96e+10, 4.56e+10, 6.51e+10, 2.09e+11, 3.09e+11, 6.68e+11, + & 2.08e+12, 3.30e+12, 5.23e+12, 8.19e+12, 1.28e+13, 1.98e+13, + & 3.08e+13, 4.81e+13, 7.55e+13, 1.19e+14, 1.89e+14, 2.49e+14, + & 3.31e+14, 3.99e+14, 4.84e+14, 5.87e+14, 7.14e+14, 1.29e+15, + & 1.58e+15, 1.93e+15, 2.37e+15, 2.91e+15, 3.58e+15, 5.44e+15, + & 8.31e+15, 1.03e+16, 1.28e+16, 1.59e+16, 1.98e+16, 2.47e+16, ! + & 3.11E+16, 3.30E+16, 3.47E+16, 3.70E+16, 3.90E+16, 4.09E+16, + & 4.25E+16, 4.48E+16, 4.67E+16, 4.93E+16, 5.16E+16, 5.45E+16, + & 5.68E+16, 5.97E+16, 6.27E+16, 6.56E+16, 6.91E+16, 7.20E+16, + & 7.55E+16, 7.98E+16, 8.41E+16, 8.86E+16, 9.34E+16, 9.83E+16, + & 1.04E+17, 1.09E+17, 1.15E+17, 1.22E+17, 1.28E+17, 1.36E+17, + & 1.44E+17, 1.52E+17, 1.61E+17, 1.69E+17, 1.79E+17, 1.89E+17, + & 2.00E+17, 2.13E+17, 2.26E+17, 2.41E+17, 2.56E+17, 2.72E+17, + & 2.88E+17, 3.06E+17, 3.26E+17, 3.46E+17, 3.68E+17, 3.92E+17, + & 4.19E+17, 4.48E+17, 4.80E+17, 5.14E+17, 5.51E+17, 5.92E+17, + & 6.38E+17, 6.86E+17, 7.36E+17, 7.95E+17, 8.65E+17, 9.45E+17, + & 1.04E+18, 1.14E+18, 1.26E+18, 1.39E+18, 1.56E+18, 1.78E+18, + & 2.04E+18, 2.43E+18, 2.89E+18, 3.40E+18, 3.96E+18, 4.57E+18, + & 5.25E+18, 6.00E+18, 6.83E+18, 7.77E+18, 8.83E+18, 1.00E+19, + & 1.14E+19, 1.29E+19, 1.46E+19, 1.66E+19, 1.87E+19, 2.12E+19, + & 2.39E+19, 2.69E+19, 3.02E+19, 3.38E+19, 3.78E+19, 4.21E+19, + & 4.68E+19, 5.19E+19, 5.75E+19, 6.34E+19, 6.97E+19, 7.66E+19, + & 8.36E+19, 9.11E+19, 9.48E+19, 9.88E+19, 1.03E+20, 1.07E+20, + & 1.09E+20, 1.11E+20, 1.14E+20, 1.17E+20/ +! & 1.09E+20, 1.11E+20, 1.13E+20, 1.15E+20/ +! MEAN MOLECULAR WEIGHT + DATA XMULE/ + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.7, + & 27.7, 27.7, 27.6, 27.6, 27.5, 27.5, 27.3, 27.2, 27.1, + & 27.0, 27.0, 27.0, 27.0, 27.0, 27.0, 27.0/ +! DENSITY IN GRAMS/CUBIT CENTIMETER + DATA DENMLE/ + & 1.40e-14, 2.46e-14, 4.46e-14, 8.25e-14, 2.01e-13, 4.13e-13, + & 8.99e-13, 2.10e-12, 3.01e-12, 9.63e-12, 1.43e-11, 3.08e-11, + & 9.60e-11, 1.53e-10, 2.42e-10, 3.78e-10, 5.89e-10, 9.12e-10, + & 1.42e-09, 2.22e-09, 3.49e-09, 5.50e-09, 8.71e-09, 1.15e-08, + & 1.53e-08, 1.84e-08, 2.23e-08, 2.71e-08, 3.29e-08, 5.96e-08, + & 7.29e-08, 8.92e-08, 1.09e-07, 1.34e-07, 1.65e-07, 2.51e-07, + & 3.84e-07, 4.75e-07, 5.90e-07, 7.34e-07, 9.15e-07, 1.14e-06, ! + & 1.43E-06, 1.52E-06, 1.60E-06, 1.71E-06, 1.80E-06, 1.89E-06, + & 1.96E-06, 2.07E-06, 2.16E-06, 2.28E-06, 2.38E-06, 2.52E-06, + & 2.63E-06, 2.76E-06, 2.89E-06, 3.03E-06, 3.19E-06, 3.33E-06, + & 3.49E-06, 3.69E-06, 3.88E-06, 4.09E-06, 4.32E-06, 4.54E-06, + & 4.79E-06, 5.04E-06, 5.31E-06, 5.62E-06, 5.91E-06, 6.27E-06, + & 6.63E-06, 7.01E-06, 7.42E-06, 7.83E-06, 8.26E-06, 8.71E-06, + & 9.26E-06, 9.84E-06, 1.04E-05, 1.11E-05, 1.18E-05, 1.26E-05, + & 1.33E-05, 1.41E-05, 1.51E-05, 1.60E-05, 1.70E-05, 1.81E-05, + & 1.94E-05, 2.07E-05, 2.22E-05, 2.38E-05, 2.55E-05, 2.73E-05, + & 2.95E-05, 3.17E-05, 3.40E-05, 3.67E-05, 4.00E-05, 4.37E-05, + & 4.78E-05, 5.26E-05, 5.80E-05, 6.40E-05, 7.20E-05, 8.22E-05, + & 9.45E-05, 1.12E-04, 1.33E-04, 1.57E-04, 1.83E-04, 2.11E-04, + & 2.43E-04, 2.77E-04, 3.16E-04, 3.59E-04, 4.08E-04, 4.62E-04, + & 5.26E-04, 5.96E-04, 6.75E-04, 7.65E-04, 8.65E-04, 9.79E-04, + & 1.10E-03, 1.24E-03, 1.39E-03, 1.56E-03, 1.74E-03, 1.94E-03, + & 2.16E-03, 2.39E-03, 2.64E-03, 2.91E-03, 3.19E-03, 3.49E-03, + & 3.79E-03, 4.12E-03, 4.27E-03, 4.43E-03, 4.62E-03, 4.80E-03, + & 4.89E-03, 4.98E-03, 5.08E-03, 5.17E-03/ +C + print*,'press ',press +c write(77,*) press +C RETURNS PRESSURE IN BARS + IF (ITIME.EQ.0) THEN + DO 201 I=1,148 + PLE(I)=PLE(I)*0.001 + ITIME=1 +201 CONTINUE + ENDIF +C AND SET ARGON AND HYDROGEN + FARGON=0. + FH2=0.003 +C + DO 202 J=1,NLEVEL + H2(J)=FH2 + AR(J)=0.0 +202 CONTINUE +C + DO 100 J=1,NLEVEL +C EXTRAPOLATE WITH ISOTHERMAL ATM ABOVE DATA POINTS + ISTART=1 + IF (PRESS(J) .LT. PLE(1) ) THEN + TEMP(J)=TLE(1) + XMU(J)=XMULE(1) + CH4(J)=CH4LE(1) + XN2(J)=XN2LE(1) + Z(J)=ZLE(1)+ALOG(PLE(1)/PRESS(J))*40.43 + DEN(J)=DLE(1)*PRESS(J)/PLE(1) + ELSE + DO 101 I=ISTART,147 +C INTERPOLATE LINEAR IN LOP P + IF (PRESS(J) .GT. PLE(I+1) ) GO TO 101 + FACTOR= ALOG(PRESS(J)/PLE(I) )/ALOG(PLE(I+1)/PLE(I)) + TEMP(J)=TLE(I) + FACTOR*(TLE(I+1) - TLE(I)) + XMU(J)=XMULE(I) + FACTOR*(XMULE(I+1) - XMULE(I)) + CH4(J)=CH4LE(I) + FACTOR*(CH4LE(I+1) - CH4LE(I)) + XN2(J)=XN2LE(I) + FACTOR*(XN2LE(I+1) - XN2LE(I)) + Z(J)=ZLE(I) + FACTOR*(ZLE(I+1) - ZLE(I)) + DEN(J)=EXP(ALOG(DLE(I))+FACTOR*(ALOG(DLE(I+1))-ALOG(DLE(I)))) + ISTART=I + GO TO 100 + 101 CONTINUE + ENDIF + 100 CONTINUE + +C SET RHCH4 AT SURFACE... + RHCH4 =CH4(NLEVEL)*PRESS(NLEVEL) / PCH4(TEMP(NLEVEL)) +C + IF (IPRINT .LT. 0) RETURN + WRITE (6,139)RHCH4,FH2,FARGON + DO 135 J=1,NLEVEL-1 + WRITE(6,140)J,Z(J),PRESS(J),DEN(J),TEMP(J), + & CH4(J)*PRESS(J)/PCH4(TEMP(J)) + & ,CH4(J)*100.,XN2(J)*100.,H2(J)*100.,AR(J)*100.,XMU(J) + & ,(TEMP(J+1)-TEMP(J))/(Z(J+1)-Z(J)) + 135 CONTINUE + J=NLEVEL + WRITE(6,140)J,Z(J),PRESS(J),DEN(J),TEMP(J), + & CH4(J)*PRESS(J)/PCH4(TEMP(J)) + & ,CH4(J)*100.,XN2(J)*100.,H2(J)*100.,AR(J)*100.,XMU(J) + 139 FORMAT(///' BACKGROUND ATMOSPHERE AT LEVELS (LELLOUCH ET AL)'/ + & ' SURFACE HUMIDITY OF CH4:',F5.3,' H2 MIXING RATIO:',F6.4, + & ' ARGON SETTING:',F8.4/' LELLOUCH ET AL RESULTS '/ + &' LVL ALTITUDE P(BARS) DEN(CM-3) TEMP RH-CH4' + & , ' %CH4 %N2 %H2 %AR MU DT/DZ' ) + 140 FORMAT(1X,I3,F8.3,1P2E10.3,0PF7.2,F5.2,2F6.2,2F5.2,4F6.2) +C + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/lell_light.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/lell_light.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/lell_light.F (revision 1643) @@ -0,0 +1,276 @@ + SUBROUTINE LELL_LIGHT(NLEVEL,Z,FARGON,TEMP,PRESS,DEN,XMU, + & CH4,H2,XN2,AR,IPRINT) + +C MODIF 20/1/00, S.Lebonnois: +c utilisation de la composition chimique directement +c inclue dans le modele + +C THIS SUBROUTINE SETS UP THE INTITAL ATMOSPHERIC PROFILE FOR TITAN +C BASED ON THE LELLOUCH AT AL DATA. THE ROUTINE STARTS WITH INPUTS +C INPUTS: +C NLEVEL: NUMBER OF ALTITUDE LEVELS, J=1 IS AT THE TOP +C P PRESS GRID IN BARS +C +C ASSUMES: FARGON = 0 +C +C OUTPUTS: +C AND AT EACH LEVEL (NOT LAYER AVERAGES) +C TEMP (K), PRESS(BARS), DEN(CM-3), XMU = MEAN MOLECULAR WEIGHT +C AR IS THE NUMBER MIXING RATIO OF Argon +C +C DATA: IS THE LELLOUCH ET AL VALUES DENOTED BY __LE(J) +C +C NEW VERSION FOR GCM : Z E [0,1200] + INTEGER ITIME + DIMENSION Z(NLEVEL),TEMP(NLEVEL),PRESS(NLEVEL), + $ DEN(NLEVEL),XMU(NLEVEL) + +c ch4,xn2,h2 sont definis ici car ils sont definis dans lell + DIMENSION CH4(NLEVEL),H2(NLEVEL),XN2(NLEVEL),AR(NLEVEL) +C + DIMENSION ZLE(148), XN2LE(148), CH4LE(148), TLE(148), PLE(148), + & DLE(148), XMULE(148), DENMLE(148) + + save ZLE,XN2LE,CH4LE,TLE,PLE,DLE,XMULE,DENMLE + save itime + data itime/0/ +C +C + DATA ZLE/ + & 1265., 1215., 1165., 1116., 1050., 1000., 950.0, 900.0, 880.0, + & 820.0, 800.0, 760.0, 700.0, 675.0, 650.0, 625.0, 600.0, 575.0, + & 550.0, 525.0, 500.0, 475.0, 450.0, 435.0, 420.0, 410.0, 400.0, + & 390.0, 380.0, 350.0, 340.0, 330.0, 320.0, 310.0, 300.0, 280.0, + & 260.0, 250.0, 240.0, 230.0, 220.0, 210.0, + & 200.0, 198.0, 196.0, 194.0, 192.0, 190.0, 188.0, 186.0, 184.0, + & 182.0, 180.0, 178.0, 176.0, 174.0, 172.0, 170.0, 168.0, 166.0, + & 164.0, 162.0, 160.0, 158.0, 156.0, 154.0, 152.0, 150.0, 148.0, + & 146.0, 144.0, 142.0, 140.0, 138.0, 136.0, 134.0, 132.0, 130.0, + & 128.0, 126.0, 124.0, 122.0, 120.0, 118.0, 116.0, 114.0, 112.0, + & 110.0, 108.0, 106.0, 104.0, 102.0, 100.0, 98.0, 96.0, 94.0, + & 92.0, 90.0, 88.0, 86.0, 84.0, 82.0, 80.0, 78.0, 76.0, + & 74.0, 72.0, 70.0, 68.0, 66.0, 64.0, 62.0, 60.0, 58.0, + & 56.0, 54.0, 52.0, 50.0, 48.0, 46.0, 44.0, 42.0, 40.0, + & 38.0, 36.0, 34.0, 32.0, 30.0, 28.0, 26.0, 24.0, 22.0, + & 20.0, 18.0, 16.0, 14.0, 12.0, 10.0, 8.0, 6.0, 5.0, + & 4.0, 3.0, 2.0, 1.5, 1.0, 0.5, 0.0/ +! N2 MIXING RATIO + DATA XN2LE/ + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, 0.985, + & 0.985, 0.985, 0.985, 0.984, 0.983, 0.983, 0.982, 0.980, 0.979, + & 0.977, 0.974, 0.971, 0.966, 0.960, 0.955, 0.945, 0.935, 0.926, + & 0.920, 0.920, 0.920, 0.920, 0.920, 0.920, 0.920/ +! CH4 MIXING RATIO + DATA CH4LE/ + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, + & 0.015, 0.015, 0.015, 0.016, 0.017, 0.017, 0.018, 0.020, 0.021, + & 0.023, 0.026, 0.029, 0.034, 0.040, 0.045, 0.055, 0.065, 0.074, + & 0.080, 0.080, 0.080, 0.080, 0.080, 0.080, 0.080/ +! TEMPERATURE IN k + DATA TLE/ + & 183.0, 181.0, 178.0, 174.7, 169.0, 164.0, 158.0, 150.0, 147.0, + & 136.0, 135.0, 137.0, 143.0, 146.5, 150.0, 154.5, 159.0, 163.5, + & 166.5, 169.0, 171.1, 172.8, 174.3, 175.1, 175.6, 175.9, 176.0, + & 176.0, 175.9, 175.8, 175.7, 175.6, 175.5, 175.4, 175.3, 175.2, + & 175.1, 175.0, 174.9, 174.8, 174.6, 174.4, + & 174.0, 173.9, 173.8, 173.6, 173.4, 173.2, 173.0, 172.9, 172.7, + & 172.5, 172.4, 172.2, 172.0, 171.8, 171.6, 171.4, 171.2, 171.0, + & 170.8, 170.4, 169.9, 169.5, 169.0, 168.5, 167.9, 167.4, 166.7, + & 166.0, 165.3, 164.5, 163.7, 163.0, 162.4, 161.8, 161.2, 160.5, + & 159.6, 158.6, 157.5, 156.3, 155.3, 154.3, 153.4, 152.6, 151.9, + & 151.0, 150.1, 149.0, 147.8, 146.5, 145.1, 143.7, 142.1, 140.6, + & 139.1, 137.6, 135.8, 133.8, 131.5, 128.8, 125.8, 122.7, 119.7, + & 116.6, 111.9, 106.1, 100.5, 92.6, 85.9, 80.9, 77.6, 75.4, + & 73.8, 72.8, 72.2, 71.7, 71.5, 71.4, 71.2, 71.1, 71.1, + & 71.2, 71.4, 71.5, 71.8, 72.3, 73.1, 73.9, 74.7, 75.7, + & 76.7, 78.0, 79.2, 80.6, 82.1, 83.6, 85.5, 87.3, 88.5, + & 89.5, 90.5, 91.5, 92.1, 92.9, 93.7, 94.5/ +! & 89.5, 90.5, 91.5, 92.1, 92.7, 93.3, 93.9/ +! PRESSURE IN MILLIBARS + DATA PLE/ + & 8.08e-09, 1.39e-08, 2.45e-08, 4.41e-08, 1.03e-07, 2.04e-07, + & 4.27e-07, 9.44e-07, 1.32e-06, 3.92e-06, 5.77e-06, 1.26e-05, + & 4.11e-05, 6.68e-05, 1.08e-04, 1.75e-04, 2.80e-04, 4.46e-04, + & 7.08e-04, 1.12e-03, 1.78e-03, 2.84e-03, 4.54e-03, 6.03e-03, + & 8.01e-03, 9.70e-03, 1.18e-02, 1.43e-02, 1.73e-02, 3.13e-02, + & 3.83e-02, 4.69e-02, 5.74e-02, 7.05e-02, 8.66e-02, 1.32e-01, + & 2.01e-01, 2.49e-01, 3.09e-01, 3.84e-01, 4.78e-01, 5.96e-01, ! + & 7.59E-01, 7.98E-01, 8.37E-01, 8.77E-01, 9.20E-01, 9.64E-01, + & 1.01E+00, 1.06E+00, 1.11E+00, 1.16E+00, 1.22E+00, 1.28E+00, + & 1.35E+00, 1.41E+00, 1.48E+00, 1.55E+00, 1.63E+00, 1.71E+00, + & 1.79E+00, 1.88E+00, 1.97E+00, 2.07E+00, 2.17E+00, 2.29E+00, + & 2.40E+00, 2.52E+00, 2.65E+00, 2.78E+00, 2.93E+00, 3.08E+00, + & 3.24E+00, 3.41E+00, 3.59E+00, 3.78E+00, 3.90E+00, 4.19E+00, + & 4.42E+00, 4.66E+00, 4.91E+00, 5.19E+00, 5.48E+00, 5.78E+00, + & 6.10E+00, 6.45E+00, 6.82E+00, 7.22E+00, 7.63E+00, 8.08E+00, + & 8.56E+00, 9.06E+00, 9.61E+00, 1.02E+01, 1.08E+01, 1.15E+01, + & 1.22E+01, 1.30E+01, 1.38E+01, 1.47E+01, 1.57E+01, 1.68E+01, + & 1.80E+01, 1.93E+01, 2.07E+01, 2.23E+01, 2.40E+01, 2.60E+01, + & 2.83E+01, 3.10E+01, 3.42E+01, 3.79E+01, 4.23E+01, 4.75E+01, + & 5.34E+01, 6.01E+01, 6.79E+01, 7.67E+01, 8.67E+01, 9.81E+01, + & 1.11E+02, 1.26E+02, 1.42E+02, 1.61E+02, 1.83E+02, 2.07E+02, + & 2.35E+02, 2.65E+02, 3.00E+02, 3.40E+02, 3.83E+02, 4.32E+02, + & 4.87E+02, 5.47E+02, 6.14E+02, 6.88E+02, 7.70E+02, 8.59E+02, + & 9.57E+02, 1.06E+03, 1.12E+03, 1.18E+03, 1.24E+03, 1.30E+03, + & 1.34E+03, 1.38E+03, 1.43E+03, 1.48E+03/ +! & 1.34E+03, 1.37E+03, 1.40E+03, 1.44E+03/ +! NUMBER DENSITY + DATA DLE/ + & 3.20e+08, 5.55e+08, 9.96e+08, 1.83e+09, 4.40e+09, 9.03e+09, + & 1.96e+10, 4.56e+10, 6.51e+10, 2.09e+11, 3.09e+11, 6.68e+11, + & 2.08e+12, 3.30e+12, 5.23e+12, 8.19e+12, 1.28e+13, 1.98e+13, + & 3.08e+13, 4.81e+13, 7.55e+13, 1.19e+14, 1.89e+14, 2.49e+14, + & 3.31e+14, 3.99e+14, 4.84e+14, 5.87e+14, 7.14e+14, 1.29e+15, + & 1.58e+15, 1.93e+15, 2.37e+15, 2.91e+15, 3.58e+15, 5.44e+15, + & 8.31e+15, 1.03e+16, 1.28e+16, 1.59e+16, 1.98e+16, 2.47e+16, ! + & 3.11E+16, 3.30E+16, 3.47E+16, 3.70E+16, 3.90E+16, 4.09E+16, + & 4.25E+16, 4.48E+16, 4.67E+16, 4.93E+16, 5.16E+16, 5.45E+16, + & 5.68E+16, 5.97E+16, 6.27E+16, 6.56E+16, 6.91E+16, 7.20E+16, + & 7.55E+16, 7.98E+16, 8.41E+16, 8.86E+16, 9.34E+16, 9.83E+16, + & 1.04E+17, 1.09E+17, 1.15E+17, 1.22E+17, 1.28E+17, 1.36E+17, + & 1.44E+17, 1.52E+17, 1.61E+17, 1.69E+17, 1.79E+17, 1.89E+17, + & 2.00E+17, 2.13E+17, 2.26E+17, 2.41E+17, 2.56E+17, 2.72E+17, + & 2.88E+17, 3.06E+17, 3.26E+17, 3.46E+17, 3.68E+17, 3.92E+17, + & 4.19E+17, 4.48E+17, 4.80E+17, 5.14E+17, 5.51E+17, 5.92E+17, + & 6.38E+17, 6.86E+17, 7.36E+17, 7.95E+17, 8.65E+17, 9.45E+17, + & 1.04E+18, 1.14E+18, 1.26E+18, 1.39E+18, 1.56E+18, 1.78E+18, + & 2.04E+18, 2.43E+18, 2.89E+18, 3.40E+18, 3.96E+18, 4.57E+18, + & 5.25E+18, 6.00E+18, 6.83E+18, 7.77E+18, 8.83E+18, 1.00E+19, + & 1.14E+19, 1.29E+19, 1.46E+19, 1.66E+19, 1.87E+19, 2.12E+19, + & 2.39E+19, 2.69E+19, 3.02E+19, 3.38E+19, 3.78E+19, 4.21E+19, + & 4.68E+19, 5.19E+19, 5.75E+19, 6.34E+19, 6.97E+19, 7.66E+19, + & 8.36E+19, 9.11E+19, 9.48E+19, 9.88E+19, 1.03E+20, 1.07E+20, + & 1.09E+20, 1.11E+20, 1.14E+20, 1.17E+20/ +! & 1.09E+20, 1.11E+20, 1.13E+20, 1.15E+20/ +! MEAN MOLECULAR WEIGHT + DATA XMULE/ + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, + & 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.8, 27.7, + & 27.7, 27.7, 27.6, 27.6, 27.5, 27.5, 27.3, 27.2, 27.1, + & 27.0, 27.0, 27.0, 27.0, 27.0, 27.0, 27.0/ +! DENSITY IN GRAMS/CUBIT CENTIMETER + DATA DENMLE/ + & 1.40e-14, 2.46e-14, 4.46e-14, 8.25e-14, 2.01e-13, 4.13e-13, + & 8.99e-13, 2.10e-12, 3.01e-12, 9.63e-12, 1.43e-11, 3.08e-11, + & 9.60e-11, 1.53e-10, 2.42e-10, 3.78e-10, 5.89e-10, 9.12e-10, + & 1.42e-09, 2.22e-09, 3.49e-09, 5.50e-09, 8.71e-09, 1.15e-08, + & 1.53e-08, 1.84e-08, 2.23e-08, 2.71e-08, 3.29e-08, 5.96e-08, + & 7.29e-08, 8.92e-08, 1.09e-07, 1.34e-07, 1.65e-07, 2.51e-07, + & 3.84e-07, 4.75e-07, 5.90e-07, 7.34e-07, 9.15e-07, 1.14e-06, ! + & 1.43E-06, 1.52E-06, 1.60E-06, 1.71E-06, 1.80E-06, 1.89E-06, + & 1.96E-06, 2.07E-06, 2.16E-06, 2.28E-06, 2.38E-06, 2.52E-06, + & 2.63E-06, 2.76E-06, 2.89E-06, 3.03E-06, 3.19E-06, 3.33E-06, + & 3.49E-06, 3.69E-06, 3.88E-06, 4.09E-06, 4.32E-06, 4.54E-06, + & 4.79E-06, 5.04E-06, 5.31E-06, 5.62E-06, 5.91E-06, 6.27E-06, + & 6.63E-06, 7.01E-06, 7.42E-06, 7.83E-06, 8.26E-06, 8.71E-06, + & 9.26E-06, 9.84E-06, 1.04E-05, 1.11E-05, 1.18E-05, 1.26E-05, + & 1.33E-05, 1.41E-05, 1.51E-05, 1.60E-05, 1.70E-05, 1.81E-05, + & 1.94E-05, 2.07E-05, 2.22E-05, 2.38E-05, 2.55E-05, 2.73E-05, + & 2.95E-05, 3.17E-05, 3.40E-05, 3.67E-05, 4.00E-05, 4.37E-05, + & 4.78E-05, 5.26E-05, 5.80E-05, 6.40E-05, 7.20E-05, 8.22E-05, + & 9.45E-05, 1.12E-04, 1.33E-04, 1.57E-04, 1.83E-04, 2.11E-04, + & 2.43E-04, 2.77E-04, 3.16E-04, 3.59E-04, 4.08E-04, 4.62E-04, + & 5.26E-04, 5.96E-04, 6.75E-04, 7.65E-04, 8.65E-04, 9.79E-04, + & 1.10E-03, 1.24E-03, 1.39E-03, 1.56E-03, 1.74E-03, 1.94E-03, + & 2.16E-03, 2.39E-03, 2.64E-03, 2.91E-03, 3.19E-03, 3.49E-03, + & 3.79E-03, 4.12E-03, 4.27E-03, 4.43E-03, 4.62E-03, 4.80E-03, + & 4.89E-03, 4.98E-03, 5.08E-03, 5.17E-03/ +C + print*,'press ',press +c write(77,*) press +C RETURNS PRESSURE IN BARS + IF (ITIME.EQ.0) THEN + DO 201 I=1,148 + PLE(I)=PLE(I)*0.001 + ITIME=1 +201 CONTINUE + ENDIF +C AND SET ARGON + FARGON=0. +C + DO 202 J=1,NLEVEL + AR(J)=0.0 +202 CONTINUE +C + DO 100 J=1,NLEVEL +C EXTRAPOLATE WITH ISOTHERMAL ATM ABOVE DATA POINTS + ISTART=1 + IF (PRESS(J) .LT. PLE(1) ) THEN + TEMP(J)=TLE(1) + XMU(J)=XMULE(1) + Z(J)=ZLE(1)+ALOG(PLE(1)/PRESS(J))*40.43 + DEN(J)=DLE(1)*PRESS(J)/PLE(1) + ELSE + DO 101 I=ISTART,147 +C INTERPOLATE LINEAR IN LOP P + IF (PRESS(J) .GT. PLE(I+1) ) GO TO 101 + FACTOR= ALOG(PRESS(J)/PLE(I) )/ALOG(PLE(I+1)/PLE(I)) + TEMP(J)=TLE(I) + FACTOR*(TLE(I+1) - TLE(I)) + XMU(J)=XMULE(I) + FACTOR*(XMULE(I+1) - XMULE(I)) + Z(J)=ZLE(I) + FACTOR*(ZLE(I+1) - ZLE(I)) + DEN(J)=EXP(ALOG(DLE(I))+FACTOR*(ALOG(DLE(I+1))-ALOG(DLE(I)))) + ISTART=I + GO TO 100 + 101 CONTINUE + ENDIF + 100 CONTINUE + +C + IF (IPRINT .LT. 0) RETURN + WRITE (6,139)FARGON + DO 135 J=1,NLEVEL-1 + WRITE(6,140)J,Z(J),PRESS(J),DEN(J),TEMP(J), + & AR(J)*100.,XMU(J) + & ,(TEMP(J+1)-TEMP(J))/(Z(J+1)-Z(J)) + 135 CONTINUE + J=NLEVEL + WRITE(6,140)J,Z(J),PRESS(J),DEN(J),TEMP(J), + & AR(J)*100.,XMU(J) + 139 FORMAT(///' BACKGROUND ATMOSPHERE AT LEVELS (LELLOUCH ET AL)'/ + & ' (light version: no composition)', + & ' ARGON SETTING:',F8.4/' LELLOUCH ET AL RESULTS '/ + &' LVL ALTITUDE P(BARS) DEN(CM-3) TEMP' + & , ' %AR MU DT/DZ' ) + 140 FORMAT(1X,I3,F8.3,1P2E10.3,0PF7.2,F5.2,4F6.2) +C + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/liqc2h6.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/liqc2h6.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/liqc2h6.F (revision 1643) @@ -0,0 +1,103 @@ + SUBROUTINE LIQC2H6(WAVELN,XNR,XNI) + +* +* +* PERS. COMM E. QUIRICO ; eric.quirico@obs.ujf-grenoble.fr +* +* + DIMENSION W(154),XN(154),XK(154) + data W/ + & 1000. ,13.7832,12.5514,11.7883,11.1533,10.5841,10.0702, + & 9.6039, 9.1789, 8.7899, 8.4325, 8.1031, 7.7984, 7.5158, + & 7.2530, 7.0079, 6.7789, 6.5643, 6.3629, 6.1383, 5.8776, + & 5.6862, 5.3808, 4.4945, 3.8012, 3.6938, 3.6004, 3.5311, + & 3.4720, 3.4149, 3.3595, 3.3060, 3.2541, 3.2038, 3.1551, + & 3.1078, 3.0620, 3.0167, 2.9724, 2.9286, 2.8869, 2.8469, + & 2.8075, 2.7699, 2.7360, 2.7037, 2.6689, 2.6345, 2.5991, + & 2.5653, 2.5339, 2.5033, 2.4734, 2.4443, 2.4158, 2.3880, + & 2.3608, 2.3343, 2.3083, 2.2829, 2.2580, 2.2337, 2.2099, + & 2.1866, 2.1638, 2.1373, 2.1135, 2.0920, 2.0707, 2.0502, + & 2.0301, 2.0105, 1.9912, 1.9722, 1.9537, 1.9354, 1.9175, + & 1.9000, 1.8827, 1.8658, 1.8492, 1.8328, 1.8168, 1.8010, + & 1.7855, 1.7702, 1.7553, 1.7405, 1.7261, 1.7118, 1.6978, + & 1.6840, 1.6704, 1.6571, 1.6440, 1.6310, 1.6183, 1.6058, + & 1.5934, 1.5813, 1.5693, 1.5575, 1.5457, 1.5342, 1.5229, + & 1.5118, 1.5009, 1.4901, 1.4795, 1.4690, 1.4586, 1.4485, + & 1.4384, 1.4285, 1.4187, 1.4091, 1.3996, 1.3902, 1.3809, + & 1.3718, 1.3628, 1.3539, 1.3451, 1.3365, 1.3279, 1.3195, + & 1.3111, 1.3029, 1.2947, 1.2867, 1.2788, 1.2709, 1.2632, + & 1.2556, 1.2480, 1.2405, 1.2332, 1.2259, 1.2187, 1.2116, + & 1.2045, 1.1976, 1.1907, 1.1839, 1.1772, 1.1705, 1.1640, + & 1.1575, 1.1510, 1.1447, 1.1384, 1.1322, 1.1282, 0.0100 + &/ + data XN/ + & 1.3267, 1.3272, 1.3294, 1.2944, 1.3174, 1.3197, 1.3211, + & 1.3217, 1.3225, 1.3229, 1.3235, 1.3242, 1.3255, 1.3286, + & 1.3266, 1.3408, 1.3029, 1.3101, 1.3149, 1.3171, 1.3188, + & 1.3196, 1.3203, 1.3226, 1.3273, 1.3298, 1.3334, 1.3432, + & 1.3569, 1.3637, 1.3311, 1.2866, 1.3017, 1.3067, 1.3099, + & 1.3120, 1.3133, 1.3139, 1.3148, 1.3153, 1.3159, 1.3162, + & 1.3167, 1.3170, 1.3371, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, + & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600 + &/ + data XK/ + &.131E-02,.394E-03,.452E-03,.987E-03,.109E-02,.118E-02,.106E-02, + &.107E-02,.102E-02,.992E-03,.997E-03,.855E-03,.849E-03,.751E-03, + &.149E-02,.125E-02,.713E-02,.148E-02,.815E-03,.213E-03,.642E-04, + &.965E-04,.375E-04,.468E-04,.863E-04,.186E-05,.451E-04,.136E-02, + &.428E-02,.237E-01,.162E-01,.273E-02,.144E-02,.416E-03,.155E-03, + &.227E-03,.361E-03,.692E-04,.509E-04,.548E-04,.105E-03,.662E-04, + &.144E-03,.133E-03,.945E-04,.395E-04,.148E-03,.455E-05,.559E-04, + &.187E-04,.929E-04,.348E-04,.896E-04,.480E-03,.471E-03,.285E-03, + &.126E-03,.446E-03,.886E-03,.843E-03,.281E-03,.625E-04,.487E-04, + &.118E-04,.437E-04,.186E-05,.336E-04,.223E-05,.101E-04,.182E-04, + &.436E-04,.171E-04,.127E-04,.186E-04,.181E-04,.243E-04,.252E-04, + &.330E-04,.294E-04,.302E-04,.258E-04,.276E-04,.335E-04,.295E-04, + &.373E-04,.351E-04,.322E-04,.653E-04,.670E-04,.882E-04,.124E-03, + &.261E-04,.973E-05,.144E-04,.356E-05,.228E-05,.475E-05,.414E-05, + &.103E-05,.980E-06,.413E-06,.283E-06,.312E-06,.996E-06,.188E-05, + &.262E-05,.282E-05,.537E-05,.262E-05,.169E-05,.314E-05,.627E-05, + &.147E-04,.975E-05,.866E-05,.161E-04,.225E-04,.315E-04,.206E-04, + &.248E-04,.157E-04,.850E-05,.155E-05,.833E-06,.523E-06,.461E-06, + &.638E-06,.959E-06,.112E-05,.130E-05,.119E-05,.120E-05,.149E-05, + &.180E-05,.183E-05,.157E-05,.190E-05,.264E-05,.178E-05,.339E-05, + &.119E-04,.117E-04,.218E-04,.345E-04,.150E-04,.159E-04,.969E-05, + &.748E-05,.879E-05,.872E-05,.444E-05,.269E-05,.241E-05,.212E-05 + &/ +*234567890123456789012345678901234567890123456789012345678901234567890 +* +* + XNR=XN(1) + XNI=XK(1) + IF (WAVELN .GT. W(1)) RETURN + XNR=XN(154) + XNI=XK(154) + IF (WAVELN .LT. W(154)) RETURN + DO 100 I=2,154 + IF (WAVELN .GT. W(I) ) GO TO 101 + 100 CONTINUE + 101 CONTINUE +C ALL INTERPOLATION IS IN LOG LAMBDA + FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I))) +C REAL PART IS LINEARLY INTERPOLATED + XNR=XN(I) + FACTOR*(XN(I-1) - XN(I)) +C IMAGINARY PART IS LOG INTERPOLATED + XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I))) + XNI=exp(XNI) + iF(XNI.lt.1.e-7) XNI=1.e-7 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/liqch4.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/liqch4.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/liqch4.F (revision 1643) @@ -0,0 +1,51 @@ + SUBROUTINE LIQCH4(WAVELN,XNR,XNI) +* +* /DATA FROM MARTONCHIK AND ORTON, 1994, Vol 33, no 36. Applied Optics/ +* Table 2, (90 K) +* + DIMENSION W(44),XN(44),XK(44) + DATA W/ + &1000.00, 71.4300, 41.6700, 8.2600, 8.1300, 7.8000, 7.6900, + & 7.5900, 3.5700, 3.4300, 3.3700, 3.3300, 3.2900, 1.9530, + & 1.9320, 1.2410, 1.2350, 1.0140, 1.0000, 0.9872, 0.9742, + & 0.8885, 0.8673, 0.8418, 0.7994, 0.7849, 0.7299, 0.7174, + & 0.7057, 0.6856, 0.6696, 0.6215, 0.5983, 0.5831, 0.4000, + & 0.1337, 0.1200, 0.1162, 0.1087, 0.1012, 0.1000, 0.0900, + & 0.0545, 0.0020/ + DATA XN/ + & 1.2930, 1.2910, 1.2900, 1.3310, 1.3250, 1.3650, 1.2750, + & 1.1950, 1.3030, 1.3000, 1.3100, 1.2780, 1.2420, 1.2850, + & 1.2850, 1.2860, 1.2860, 1.2870, 1.2870, 1.2870, 1.2870, + & 1.2880, 1.2880, 1.2880, 1.2880, 1.2890, 1.2890, 1.2890, + & 1.2890, 1.2900, 1.2900, 1.2910, 1.2910, 1.2910, 1.2990, + & 1.7030, 1.4860, 1.4710, 1.5080, 1.4450, 1.4480, 1.2090, + & 0.8560, 1.0000/ + DATA XK/ + &5.302e-05, 1.442e-03, 6.645e-04, 1.067e-02, 2.135e-02, 7.994e-02, + &1.706e-02, 7.728e-02, 1.066e-02, 2.132e-02, 4.264e-02, 7.462e-02, + &3.198e-02, 8.947e-07, 1.574e-06, 8.425e-08, 1.677e-07, 1.000e-06, + &8.313e-07, 6.281e-07, 4.958e-07, 1.899e-06, 3.311e-07, 4.998e-08, + &6.103e-08, 3.995e-08, 9.907e-08, 1.156e-07, 8.381e-09, 2.675e-09, + &4.771e-09, 1.951e-07, 1.167e-09, 1.237e-09, 1.000e-10, 1.814e-01, + &3.336e-01, 3.225e-01, 3.761e-01, 4.768e-01, 4.853e-01, 6.501e-01, + &2.137e-01, 1.137e-01/ + XNR=XN(1) + XNI=XK(1) + IF (WAVELN .GT. W(1)) RETURN + XNR=XN(44) + XNI=XK(44) + IF (WAVELN .LT. W(44)) RETURN + DO 100 I=2,44 + IF (WAVELN .GT. W(I) ) GO TO 101 + 100 CONTINUE + 101 CONTINUE +C ALL INTERPOLATION IS IN LOG LAMBDA + FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I))) +C REAL PART IS LINEARLY INTERPOLATED + XNR=XN(I) + FACTOR*(XN(I-1) - XN(I)) +C IMAGINARY PART IS LOG INTERPOLATED + XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I))) + XNI=exp(XNI) + iF(XNI.lt.1.e-7) XNI=1.e-7 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/microtab.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/microtab.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/microtab.h (revision 1643) @@ -0,0 +1,35 @@ +!------------------------------------------------------------------- +! INCLUDE microtab.h +! + REAL wco,df_GP + INTEGER nz,nrad,imono,nztop,ntype + + parameter(nz=llm,ntype=5,nrad=10,imono=5,nztop=1) !VERSION X +! parameter(nz=llm,ntype=1,nrad=10,imono=5,nztop=1) !VERSION X + + parameter(wco=177.,df_GP=2.) !FOR FRACTAL PARTCICLES +! parameter(wco=1.E+6,df_GP=3.) !FOR SPHERE PARTICLES + + real rf(nrad),df(nrad),zf,aknc + common/frac/rf,df,zf,aknc + +!******************************************************************** +! tcorrect, tx, microfi, cutoff: definis dans physiq.def (clesphys.h) +!------------ + ! WARNING: tx=production rate + ! tcorrect is readjustment factor: =1 is continiuty + ! =X is q()*X +!------------ +!(*1): si microfi=1, optcv et optci sont appeles a chaque appels de la +! physique pour reactualiser les TAU's. De meme, pg2.F est +! active a chaque appel de la physique.... +! si microfi=0., optcv et optci, ainsi que pg2, ne sont appele qu'une +! fois au debut, comme dans la version originale.... +!------------ +! dans optci et optcv: +! si cutoff=1, brume coupee facon Pascal -> T ok au sol et dans la strato +! -> T tropopause mauvaise +! -> albedo ok +! si cutoff=2, brume coupee sous 100mbar -> T ok sol/tropopause/strato +! -> mais albedo mauvais + Index: trunk/LMDZ.TITAN.old/libf/phytitan/mucorr.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/mucorr.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/mucorr.F (revision 1643) @@ -0,0 +1,120 @@ + SUBROUTINE mucorr(npts,lon_sun, plat, pmu, pfract) + IMPLICIT NONE + +c======================================================================= +c +c Calcul of equivalent solar angle and and fraction of day whithout +c diurnal cycle. +c +c parmeters : +c ----------- +c +c Input : +c ------- +c npts number of points +c lon_sun solar longitude (radians!!) +c plat(npts) latitude (en degres) +c +c Output : +c -------- +c pmu(npts) equivalent cosinus of the solar angle +c pfract(npts) fractionnal day +c +c======================================================================= + +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ----------------- + +#include "YOMCST.h" +#include "comorbit.h" + +c Arguments : +c ----------- + INTEGER npts + REAL plat(npts),pmu(npts), pfract(npts) + REAL lon_sun +c +c Local variables : +c ----------------- + INTEGER j + REAL z,cz,sz,tz,phi,cphi,sphi,tphi + REAL ap,a,t,b,tp + real pdeclin,incl + +c----------------------------------------------------------------------- + +c verifs +c print*,"LATITUDES=",plat(1),plat(npts/2),plat(npts) +c print*,"zls=",lon_sun*180/RPI + + incl=obliquit * RPI / 180. ! obliquite en radian + pdeclin = ASIN (SIN(lon_sun)*SIN(incl) ) ! declin en radian +c print*,'npts,pdeclin',npts,pdeclin*180./RPI + z = pdeclin + cz = cos (z) + sz = sin (z) +c print*,'cz,sz',cz,sz + + DO 20 j = 1, npts + + phi = plat(j)*RPI/180. ! latitude en radian + cphi = cos(phi) + if (cphi.le.1.e-9) cphi=1.e-9 + sphi = sin(phi) + tphi = sphi / cphi + b = cphi * cz + t = -tphi * sz / cz + a = 1.0 - t*t + ap = a + + IF(t.eq.0.) then + t=0.5*RPI + ELSE + IF (a.lt.0.) a = 0. + t = sqrt(a) / t + IF (t.lt.0.) then + tp = -atan (-t) + RPI + ELSE + tp = atan(t) + ENDIF + t = tp + ENDIF + + pmu(j) = (sphi*sz*t) / RPI + b*sin(t)/RPI + pfract(j) = t / RPI + IF (ap .lt.0.) then + pmu(j) = sphi * sz + pfract(j) = 1.0 + ENDIF + + IF (pmu(j).le.0.0) pmu(j) = 0.0 + pmu(j) = pmu(j) / pfract(j) + IF (pmu(j).eq.0.) pfract(j) = 0. + + 20 CONTINUE +c call dump2d(48,31,pfract(2),'FRACT ') +c call dump2d(48,31,pmu(2),'MU0 ') +c stop + +c----------------------------------------------------------------------- +c correction de rotondite: +c ------------------------ + +c print*,'dans mucorr avant correction rotondite' +c print*,'pmu(1)=',pmu(1),' pmu(npts/2)=',pmu(npts/2) +c print*,'pfract(1)=',pfract(1),' pfract(npts/2)=',pfract(npts/2) + + DO 30 j=1,npts +c !!!!!! + pmu(j)=sqrt(1224.*pmu(j)*pmu(j)+1.)/35. +30 CONTINUE + +c print*,'dans mucorr apres correction rotondite' +c print*,'pmu(1)=',pmu(1),' pmu(npts/2)=',pmu(npts/2) + +c print*,"pmu=",pmu(1),pmu(npts/2),pmu(npts) +c print*,"pfract=",pfract(1),pfract(npts/2),pfract(npts) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/muphys3D.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/muphys3D.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/muphys3D.F (revision 1643) @@ -0,0 +1,532 @@ + subroutine muphys(ngrid, + & plev,play,zlev,zlay, + & tpt,tq,gaz1,gaz2,gaz3, + & nmicro,ptimestep, + & pmu0,pfract, +* Sorties diagnostiques + & flxesp_i, + & tau_drop,tau_aer, + & solesp,prec) + +c +c +c CETTE NOUVELLE ROUTINE DE MICROPHYSIQUE GERE +c LA MICROPHYSIQUE DES AEROSOLS ET CELLE DES NUAGES +c EN UN SEUL APPEL... +c +c TOUS LES TRACEURS AEROSOL+NOYAUX+2*GLACES SONT CONTENUS DANS +c LE TABLEAU TQ ET LEUR TENDANCES DANS TDQ. CES TABLEAUX +c SONT COMPOSES DE TROIS PARTIES: +c +c TQ( 1, nmicro/4 pour les aerosols +c + nmicro/4+1, 2*nmicro/4 pour les noyaux +c + 2*nmicro/4+1, 3*nmicro/4 pour la glace 1 +c + 3*nmicro/4+1, nmicro ) pour la glace 2 +c +c pour les aerosols, les noyaux, la glace 1 et la glace 2. la separation +c puis la concatenation de fait juste avant l'appel aux routines +c dans lesquels la separation est necessaire. +c +c _______ +c | | ____ +c EX: --------> QAER() ----> | M | \ +c / | I | \ +c / | C | \ +c TQ() ----------> QGLACE1() ---> | R | ------ TDQ() +c \ | O | / +c \ | P | / +c --------> QGLACE2() ----> | H | ----/ +c \ | Y | / +c \ | | / +c -----> QNOYAUX() | | _/ +c | | +c ------- +c +c +c +c DANS LA MICROPHYSIQUE, SE TROUVENT IMBRIQUES LES PROCESSUS SUIVANTS +c +c +c +c +c +c NUCLEATION/SEDIMENTATION ---> n_ethane.F / n_methane.F +c +c MICROPHYSIQUE AEROSOLS ---> brume.F +c +c SEDIMENTATION DES GOUTTES ---> snuages.F +c +c +c +c +c +c +c------------------------------------------------------ + use dimphy +c use radcommon_h, only : volume,rayon,vrat,drayon,dvolume + USE geometry_mod, only: latitude ! in radians + + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" +#include "clesphys.h" +#include "itemps.h" + + integer ngrid + + integer iq,nmicro + real ptimestep + real pdpsrf(ngrid) + +c a la place de radcommon_h: + common/part/vaer,raer,vrat,draer,dvaer + real vaer(nrad),raer(nrad),vrat, + & draer(nrad),dvaer(nrad) + +c************************************* +c declaration des variables internes * +c************************************* + +c sources * +c------------------* + + REAL plev(ngrid,klev+1) + REAL play(ngrid,klev) + REAL zlev(ngrid,klev+1) + REAL zlay(ngrid,klev) + REAL pu(ngrid),pv(ngrid) + REAL pmu0(ngrid),pfract(ngrid) + REAL tpt(ngrid,klev) + REAL tq(ngrid,klev,nmicro), + & gaz1(ngrid,klev), + & gaz2(ngrid,klev), + & gaz3(ngrid,klev) + +c OUTPUT !!!!! c +c note : gaz1,...,gazN sont aussi des outputs, ils ont modifié tout au long de muphys. +c--------------------c + REAL pdq(ngrid,klev,nmicro) + REAL flxesp_i(ngrid,klev,3) ! flx esp GLACE + REAL solesp(ngrid,klev,3) ! tx prod glace (puit/source) + REAL tau_drop(ngrid,klev) + REAL tau_aer(ngrid,klev,nrad) + REAL prec(ngrid,5) + +c LOCAL +c--------------------c + real q(ngrid,klev,nmicro) + REAL taused(klev,nrad) + integer jsup,jinf,h,jalt,ihor,k,im1 + +c microphysique * +c---------------------* + real c(klev,nrad), cni(klev,nrad) + real c1i(klev,nrad),c2i(klev,nrad),c3i(klev,nrad) + real gazc1(klev),gazc2(klev),gazc3(klev) + real ddt + + real vcl,nuc,r,xgsn,xmsn + real zz,effg,xlog,rapport + + integer IPREM,i,n,j,l + integer ibid + save IPREM + data IPREM/0/ + + +c real ttq(ngrid,klev,nmicro,2) +c real tttq(ngrid,klev,nmicro,2) + + +c ************************** +c INITIALISATION DE TABLEAUX +c ************************** +c A NE FAIRE QU'UNE FOIS +c ************************** +c + IF (IPREM.eq.0) THEN + + IF (ngrid.ne.klon) THEN + print*,"aLeRte :" + print*,"microfi, mais ngrid.ne.klon" + print*,ngrid,klon + stop "je m'arrete... (muphys3D)" + ENDIF + +c initialisation des constantes de la microphysique : +c ---------------------------------------------- + call inimphycst() + + +c initialisation des c(z,r), c1i(z,r), c2i(z,r) +c ---------------------------------------------- + + do i=1,nmicro + do n=1,ngrid + do j=klev,1,-1 + q(n,klev+1-j,i)=tq(n,j,i) ! glaces... + if(i.le.2*nrad) q(n,klev+1-j,i)=tq(n,j,i)*tcorrect ! noyaux+aerosol + pdq(n,j,i)=0. + enddo + enddo + enddo +c ici, les tableaux definissant la structure des aerosols sont +c remplis: rf,df(nmicro),r(nmicro),v(nmicro)...... + call rdf() +c ici on recopie la grille dans un common specifique a la microfi... +c v_e = volume +c r_e = rayon +c vrat_e = vrat +c dr_e = drayon +c dv_e = dvolume + v_e = vaer + r_e = raer + vrat_e = vrat + dr_e = draer + dv_e = dvaer +c + ELSE + +c les tq() doivent etre en nombre d'aerosols / cases + + do j=1,klev ! j de 1 a 119 + do n=1,ngrid + do i=1,nmicro + q(n,j,i)=tq(n,klev-j+1,i) + pdq(n,j,i)=0. + enddo + enddo + enddo + + ENDIF ! FIN IPREM + + +c----------------------------------------------------- +c !! La premiere fois, on ne passe pas par +c !! q--->c et par pg3.F +c !! on passe directement au remplissage c-->q + IF (IPREM.eq.0) goto 102 +c----------------------------------------------------- + +c**************************************** +c * +c ADAPTATION GCM > micro * +c * +c**************************************** + + +c correpondance des couches / sens GCM > microphysique +c----------------------------------------------------- + +c*************************************************************** + do IHOR=1,NGRID ! GRANDE BOUCLE HORIZONTALE / SEPARATION DES COLONNES + + if (IHOR.eq.1) then + im1=1 + else + im1=IHOR-1 + endif + +c*************************************************************** +c On refait les calculs si on est au premier point +c OU si on change de latitude +c OU si on calcule la microfi en 3D +c*************************************************************** + if((IHOR.eq.1) + & .or.(latitude(IHOR).ne.latitude(im1)) + & .or.(microfi.eq.2)) then +c*************************************************************** + +c Ici, on initialise la grille verticale et les +c variables communes aux routines de microphysique. +c******************************************************* + call inimuphy(ihor,plev(ihor,:),play(ihor,:), + & zlev(ihor,:),zlay(ihor,:), + & tpt(ihor,:)) + +c Ici, on scinde les tableaux aerosols et glaces +c******************************************************* + + if (clouds.eq.0) then + if(nrad .ne. nmicro) then + print*,"aLeRte : nrad != nmicro" + print*,'nmicro= ',nmicro + print*,'nrad= ',nrad + stop "je m'arrete..." + endif + else + if(nrad .ne. nmicro/ntype) then + print*,"aLeRte : nrad != nmicro/ntype" + print*,'nmicro= ',nmicro + print*,'ntype=',ntype + print*,'nmicro/ntype= ',nmicro/ntype + print*,'nrad= ',nrad + stop "je m'arrete..." + endif + endif + + do i=1,nrad + do j=1,klev + c(j,i) =q(IHOR,j,i )/dzb(j) ! concentration aerosols/m^3 + if (clouds.eq.1) then + cni(j,i)=q(IHOR,j,i+ nrad)/dzb(j) ! concentration noyaux /m^3 + c1i(j,i)=q(IHOR,j,i+2*nrad)/dzb(j) ! concentration volume glace/m^3 + c2i(j,i)=q(IHOR,j,i+3*nrad)/dzb(j) ! concentration volume glace /m^3 + c3i(j,i)=q(IHOR,j,i+4*nrad)/dzb(j) ! concentration volume glace /m^3 + endif + enddo + enddo + if (clouds.eq.1) then + do j=1,klev + gazc1(j) =gaz1(IHOR,klev-j+1) ! fraction molaire CH4 + gazc2(j) =gaz2(IHOR,klev-j+1) ! fraction molaire C2H6 + gazc3(j) =gaz3(IHOR,klev-j+1) ! fraction molaire C2H2 + enddo + endif + +c**************************************** +c +c FIN DE LA PREPARATION: +c +c +c ON APPELLE LES MODELES MICROPHYSIQUES +c +c - brume (coagulation + sedimentation) +c - nuages (nucleation + condensation) +c - sedimentation nuages +c +c +c**************************************** + + + do j=1,klev + solesp(ihor,klev+1-j,:) = 0. + do i=1,nrad + tau_aer(ihor,klev+1-j,i)=0. + enddo + enddo + + ddt=ptimestep + +* concerne les aerosols (tableau c): +c call begintime(tt0) + call brume(ngrid,c,ddt,klev,nrad,taused,ihor, + & pmu0(ihor),pfract(ihor), + & prec) +c call endtime(tt0,tt1) +c tthaze=tthaze+tt1 + +* concerne aerosols + gouttes (tableaux c,cn,c1,c2): + + do j=1,klev + do i=1,nrad + tau_aer(ihor,klev+1-j,i)=tau_aer(ihor,klev+1-j,i) + & +taused(j,i) + enddo + enddo + + IF (clouds.eq.1) THEN + +c do j=1,klev +c do i=1,nrad +c ttq(ihor,klev-j+1,i,1) = c(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+nrad,1) = cni(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+2*nrad,1) = c1i(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+3*nrad,1) = c2i(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+4*nrad,1) = c3i(j,i)*dzb(j) +c enddo +c enddo + +c call begintime(tt0) + call cnuages(c,c1i,c2i,c3i,cni, + & gazc1,gazc2,gazc3,ddt) +c call endtime(tt0,tt1) +c ttcclds=ttcclds+tt1 + +c verification des valeurs de c,cni,c1i,c2i et c3i. +c Lorsque l'on vide completement une case, on peut avoir des chiffres negatifs :s + do j=1,klev + do i=1,nrad + c(j,i)= MAX(c(j,i),0.) + cni(j,i)= MAX(cni(j,i),0.) + c1i(j,i)= MAX(c1i(j,i),0.) + c2i(j,i)= MAX(c2i(j,i),0.) + c3i(j,i)= MAX(c3i(j,i),0.) +c ttq(ihor,klev-j+1,i,2) = c(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+nrad,2) = cni(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+2*nrad,2) = c1i(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+3*nrad,2) = c2i(j,i)*dzb(j) +c ttq(ihor,klev-j+1,i+4*nrad,2) = c3i(j,i)*dzb(j) + enddo + enddo + + + do j=1,klev + do i=1,nrad +! solesp en m3/m3 pour passer en m3/m2 il faut faire : +! (c1i(j,i)*dzb(j) -q(IHOR,j,i+2*nrad)) + solesp(ihor,klev+1-j,1)=solesp(ihor,klev+1-j,1) + + & (c1i(j,i)-q(IHOR,j,i+2*nrad)/dzb(j)) + solesp(ihor,klev+1-j,2)=solesp(ihor,klev+1-j,2) + + & (c2i(j,i)-q(IHOR,j,i+3*nrad)/dzb(j)) + solesp(ihor,klev+1-j,3)=solesp(ihor,klev+1-j,3) + + & (c3i(j,i)-q(IHOR,j,i+4*nrad)/dzb(j)) + enddo + enddo + +* concerne les gouttes (tableaux cn,c1,c2): + +c do j=1,klev +c do i=1,nrad +c tttq(ihor,klev-j+1,i,1) = c(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+nrad,1) = cni(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+2*nrad,1) = c1i(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+3*nrad,1) = c2i(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+4*nrad,1) = c3i(j,i)*dzb(j) +c enddo +c enddo + +c call begintime(tt0) + call snuages(ngrid,cni,c1i,c2i,c3i,c,ddt, + & klev,nrad,ihor, + & flxesp_i,tau_drop,prec) +c call endtime(tt0,tt1) +c ttsclds=ttsclds+tt1 + +c do j=1,klev +c do i=1,nrad +c tttq(ihor,klev-j+1,i,2) = c(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+nrad,2) = cni(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+2*nrad,2) = c1i(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+3*nrad,2) = c2i(j,i)*dzb(j) +c tttq(ihor,klev-j+1,i+4*nrad,2) = c3i(j,i)*dzb(j) +c enddo +c enddo + ENDIF ! flag nuages :) + + +* on recompose le tableau de traceurs ici. +*-------------------------------------------------- + + do i=1,nrad + do j=1,klev + q(IHOR,j,i) = c(j,i)*dzb(j) ! nombre aerosols /m^2 + if (clouds.eq.1) then + q(IHOR,j,i+ nrad) = cni(j,i)*dzb(j) ! nombre noyaux /m^2 + q(IHOR,j,i+2*nrad) = c1i(j,i)*dzb(j) ! concentration volume glace/m^2 + q(IHOR,j,i+3*nrad) = c2i(j,i)*dzb(j) ! concentration volume glace/m^2 + q(IHOR,j,i+4*nrad) = c3i(j,i)*dzb(j) ! concentration volume glace/m^2 + endif + enddo + enddo + if (clouds.eq.1) then + do j=1,klev + gaz1(IHOR,klev-j+1) = gazc1(j) ! fraction molaire + gaz2(IHOR,klev-j+1) = gazc2(j) ! fraction molaire + gaz3(IHOR,klev-j+1) = gazc3(j) ! fraction molaire + enddo + endif + +c*************************************************************** + else ! same latitude, we don't do calculations again + q(ihor,:,:) = q(im1,:,:) + tau_aer(ihor,:,:) = tau_aer(im1,:,:) + prec(ihor,:) = prec(im1,:) + if (clouds.eq.1) then + solesp(ihor,:,:) = solesp(im1,:,:) + flxesp_i(ihor,:,:) = flxesp_i(im1,:,:) + tau_drop(ihor,:) = tau_drop(im1,:) + gaz1(ihor,:) = gaz1(im1,:) + gaz2(ihor,:) = gaz2(im1,:) + gaz3(ihor,:) = gaz3(im1,:) + endif + endif + + ENDDO ! Fin de la boucle IHOR +c*************************************************************** + +102 CONTINUE ! la premiere fois, c'est une boucle vide! + + +c*************************************************************** +c FIN: on renvoie les nouvelles valeurs q(t+dt)=q(t) + dq(t) +c +c Pour les aerosols, les noyaux, les glaces et les vapeurs modifiees... +c +c*************************************************************** + + do n=1,ngrid + do i=1,nmicro + do j=1,klev ! j de 1 a 54 + tq(n,j,i) = q(n,klev+1-j,i) + enddo + enddo + enddo + + +c do j=1,15 +cc CH4 -- cnuages +c write(210,'(I4,3(ES24.16,1X))') j, +c & sum(ttq(40,j,2*nrad+1:3*nrad,1)), +c & sum(ttq(40,j,2*nrad+1:3*nrad,2)), +c & sum(ttq(40,j,2*nrad+1:3*nrad,2))- +c & sum(ttq(40,j,2*nrad+1:3*nrad,1)) +cc C2H6 -- cnuages +c write(211,'(I4,3(ES24.16,1X))') j, +c & sum(ttq(40,j,3*nrad+1:4*nrad,1)), +c & sum(ttq(40,j,3*nrad+1:4*nrad,2)), +c & sum(ttq(40,j,3*nrad+1:4*nrad,2))- +c & sum(ttq(40,j,3*nrad+1:4*nrad,1)) +cc C2H2 -- cnuages +c write(212,'(I4,3(ES24.16,1X))') j, +c & sum(ttq(40,j,4*nrad+1:5*nrad,1)), +c & sum(ttq(40,j,4*nrad+1:5*nrad,2)), +c & sum(ttq(40,j,4*nrad+1:5*nrad,2))- +c & sum(ttq(40,j,4*nrad+1:5*nrad,1)) +c +cc CH4 -- snuages +c write(310,'(I4,3(ES24.16,1X))') j, +c & sum(tttq(40,j,2*nrad+1:3*nrad,1)), +c & sum(tttq(40,j,2*nrad+1:3*nrad,2)), +c & sum(tttq(40,j,2*nrad+1:3*nrad,2))- +c & sum(tttq(40,j,2*nrad+1:3*nrad,1)) +cc C2H6 -- snuages +c write(311,'(I4,3(ES24.16,1X))') j, +c & sum(tttq(40,j,3*nrad+1:4*nrad,1)), +c & sum(tttq(40,j,3*nrad+1:4*nrad,2)), +c & sum(tttq(40,j,3*nrad+1:4*nrad,2))- +c & sum(tttq(40,j,3*nrad+1:4*nrad,1)) +cc C2H2 -- snuages +c write(312,'(I4,3(ES24.16,1X))') j, +c & sum(tttq(40,j,4*nrad+1:5*nrad,1)), +c & sum(tttq(40,j,4*nrad+1:5*nrad,2)), +c & sum(tttq(40,j,4*nrad+1:5*nrad,2))- +c & sum(tttq(40,j,4*nrad+1:5*nrad,1)) +c enddo +c write(210,*) "NEWLINE" +c write(211,*) "NEWLINE" +c write(212,*) "NEWLINE" +c write(310,*) "NEWLINE" +c write(311,*) "NEWLINE" +c write(312,*) "NEWLINE" + + +c do j=1,20 +c write(410,'(I4,3(ES24.16,1X))') j, +c & flxesp_i(40,j,1),flxesp_i(40,j,2),flxesp_i(40,j,3) +c write(510,'(I4,3(ES24.16,1X))') j, +c & solesp(40,j,1),solesp(40,j,2),solesp(40,j,3) +c enddo +c write(410,*) "NEWLINE" +c write(510,*) "NEWLINE" + + IPREM=1 ! LA PROCHAINE FOIS NE SERA PLUS LA 1ERE + + + 16 return + + end + + +c--------------------------------------------------------------------- Index: trunk/LMDZ.TITAN.old/libf/phytitan/n_acethylene.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/n_acethylene.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/n_acethylene.F (revision 1643) @@ -0,0 +1,598 @@ + subroutine n_acethylene(ngrid,nq,nbin, + * dt,pl,tl,aerad, + * q,qprime) + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c Arguments +c --------- + + integer ngrid,nq,nbin + + REAL dt ! physical time step (s) + REAL pl(ngrid,nz) ! pressure at each level (mbar) + REAL tl(ngrid,nz) ! temperature at each level (K) + REAL aerad(nbin) ! Radius array + +c Tracers : + REAL q(ngrid,nz,nq) ! tracer (kg/kg) + REAL qprime(ngrid,nz,nbin) ! tracer (kg/kg) + + +c Local variables +c --------------- + + integer ntyp + parameter (ntyp=3) + + real n_aer(nz,nbin,ntyp) + real c2h2vap(nz) + + integer itrac + integer ig,i,j,k,l,n ! Loop integers + integer ilay,iq + +c Treatment +c --------- + + DO ig = 1 , NGRID + +c Set up the aerosol array + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + n_aer(l,k,j) = max(q(ig,l,itrac),0.) + enddo + enddo + enddo + +c Set up the methane vapor array + do l = 1, nz + c2h2vap(l) = q(ig,l,nq) + enddo + + call nucleacond3(ngrid,nbin,dt,ig,pl,tl,aerad, + & n_aer,qprime,c2h2vap) + +c Update q arrays + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + q(ig,l,itrac) = n_aer(l,k,j) + enddo + enddo + enddo + +c Update methane vapor array + do l = 1, nz + q(ig,l,nq) = c2h2vap(l) + enddo + + ENDDO + + return + END + +**************************************************************** + subroutine nucleacond3(ngrid,nbin,dt,ig, + * pl,tl,aerad,n_aer,qprime,c2h2vap) +* * +* This routine updates species concentrations due * +* to both nucleation and condensation-induced variations. * +* Gain and loss rates associated to each one of these * +* processes are computed separately in other routines. * +* * +**************************************************************** + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer ng,nalt + parameter(ng=1,nalt=llm) + + + real lv + + common/lheat/lv + + + +c Arguments +c --------- + + integer ngrid,nbin + integer ig + integer ntyp + parameter (ntyp=3) + + real dt ! Global time step + real pl(ngrid,nz),tl(ngrid,nz) + real aerad(nbin) + real c2h2vap(nz) ! Methane vapor mass mixing ratio (kg/m3) + real c2h2vap_old + real n_aer(nz,nbin,ntyp) ! number concentrations of particle/each size bin + real qprime(ngrid,nz,nbin) ! tracer (kg/kg) + REAL total1(nz),total11(nz),total2(nz),total22(nz) + REAL dmsm,mtot + + + + + +c Local +c ----- + + integer i,j,k,l,n,iindice,iselec + + real dQc ! Amount of condensed methane (kg/m3) during timestep + real*8 sat_ratio ! Methane saturation ratio over liquid + real*8 sat_ratmix ! Methane saturation ratio over liquid + real*8 pc2h2 ! Methane partial pressure (Pa) + real qsat ! Methane mass mixing ratio at saturation (kg/kg of air) + real qsatmix ! Methane mass mixing ratio at saturation (kg/kg of air) + real*8 rate(nbin) ! Heterogeneous Nucleation rate (s-1) + real*8 elim + + real nsav(nbin,ntyp) + real dn(nbin,ntyp) + real rad(nbin) ! Radius of droplets in each size bin + real*8 gr(nbin) ! Growth rate in each bin + real radius ! Radius of droplets after growth + real Qs ! Mass of condensate required to reach saturation + real newsat + real vol(nbin) + + real press + real sig3,temp,seq(nbin) + real Ctot,up,dwn,newvap,gltot + + real temp0,temp1,temp2,last_temp + real qsat1,sat_ratio1,tempf(0:10),sat_ratiof(0:10) + real rho_a,cap + real tempref + real xtime,xtime_prime + + +c Variables for latent heat release + real lw + data lw / 581.e+3/ + save lw + + +c Treatment +c --------- + do i = 1, nbin + vol(i) = 4./3. * pi * aerad(i)**3. + enddo + + do l = 1, nz + total1(l)=0. !solide + do k = 1, nbin + total1(l)=total1(l)+n_aer(l,k,2)*rhoi_c2h2 + enddo + total2(l)=c2h2vap(l) + enddo + + +c Start loop over heights + DO 100 l = 1, nz + + iindice=0 ! mettre l'indice à 0 + + temp = tl(ig,l) + press = pl(ig,l) + tempref=temp + +c Save the values of the particle arrays before condensation + do j = 1, ntyp + do i = 1, nbin + nsav(i,j) = n_aer(l,i,j) + enddo + enddo + + + 99 continue + + + call c2h2sat(temp,press,qsat) + qsatmix=qsat + +c quantité pmixc2h2(l) déjà calculé dans cnuages.F et passé dans un common + +c Get the partial presure of methane vapor and its saturation ratio + pc2h2 = c2h2vap(l) * (Mn2/Mc2h2) * press + sat_ratio = c2h2vap(l) / qsat + sat_ratmix = c2h2vap(l) / qsatmix + +c Get the rates of nucleation + call nuclea3(nbin,aerad,pc2h2,temp,sat_ratio,rate) + +c Get the growth rates of condensation/sublimation + up = c2h2vap(l) + dwn = 1. + Ctot = c2h2vap(l) + DO i = 1, nbin + + if (n_aer(l,i,3).eq.0) then + rad(i) = aerad(i) + else + rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) + + & qprime(ig,l,i)/n_aer(l,i,3) + & +vol(i))*0.75/pi)**(1./3.) + endif + + +* Equilibrium saturation ratio (due to curvature effect) + seq(i) = exp( 2.*sig3(temp)*Mc2h2 /(rhoi_c2h2*rgp*temp*rad(i))) + + call growthrate3(dt,temp,press,pc2h2, + & sat_ratmix,seq(i),rad(i),gr(i)) + + up = up + dt * gr(i) * 4. * pi * rhoi_c2h2 * rad(i) * seq(i) + * * nsav(i,3) + dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_c2h2 * rad(i) / qsat + * * nsav(i,3) + Ctot= Ctot + rhoi_c2h2 * nsav(i,2) + + ENDDO + + newvap = min(up/dwn,Ctot) + newvap = max(newvap,0.) + + gltot = 0. + DO i = 1, nbin + gr(i) = gr(i) * ( newvap/qsat - seq(i) ) + if(nsav(i,2).le.0. .and. gr(i).le.0.) then + n_aer(l,i,2) = 0. + else + n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i) + * * n_aer(l,i,3) + if (n_aer(l,i,2).le.0.) then + n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3) + n_aer(l,i,2) = 0. + n_aer(l,i,3) = 0. + endif + gltot=n_aer(l,i,2)*rhoi_c2h2+gltot + endif + + ENDDO + +c Determine the mass of exchanged methane + + dQc = 0. + DO i = 1, nbin + dQc = dQc - rhoi_c2h2 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + +c Update the methane vapor mixing ratio implied by +c the cond/eva processes. + + +c Arrays resetted to their initial value before condensation + do j = 1, ntyp + do i = 1, nbin + dn(i,j) = n_aer(l,i,j) - nsav(i,j) + n_aer(l,i,j) = nsav(i,j) + enddo + enddo + +c Update the c arrays. +c nucleation & cond/eva tendencies added together. + + do i=1,nbin + elim = dt * rate(i) + n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim) + n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3) + n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1) + n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2) + if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0. + enddo + + dQc = 0. + DO i = 1, nbin + dQc = dQc - rhoi_c2h2 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + + + c2h2vap(l) = c2h2vap(l) + dQc + +100 CONTINUE + + do l = 1, nz + total11(l)=0. + do k = 1, nbin + total11(l)=total11(l)+n_aer(l,k,2)*rhoi_c2h2 + enddo + total22(l)=c2h2vap(l) + enddo + + return + end + + +******************************************************* +* * + subroutine nuclea3(nbin,aerad,pc2h2,temp,sat,nucrate) +* This subroutine computes the nucleation rate * +* as given in Pruppacher & Klett (1978) in the * +* case of water ice forming on a solid substrate. * +* Definition refined by Keese (jgr,1989) * +* * +******************************************************* + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer nbin + real aerad(nbin) + + real*8 nucrate(nbin) + real*8 pc2h2 + real temp + real*8 sat + + integer l,i + real*8 nc2h2 + real sig3 ! Water-ice/air surface tension (N.m) + real*8 rstar ! Radius of the critical germ (m) + real*8 gstar ! # of molecules forming a critical embryo + real*8 x ! Ratio rstar/radius of the nucleating dust particle + real fistar ! Activation energy required to form a critical embryo (J) + real*8 zeldov ! Zeldovitch factor (no dim) + real*8 fshape3 ! function defined at the end of the file + real*8 deltaf + + real nus + data nus/1.e+13/ ! Jump frequency of a molecule (s-1) + real m0 + data m0/4.31894e-26/ ! Weight of a methane molecule (kg) + real vo1 + data vo1/4.22764e-5/ ! Volume molaire (masse molaire/masse volumique = MolWt/LDEN) + real desorp + data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule) + real surfdif + data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule) + + IF (sat .GT. 1.) then ! minimum condition to activate nucleation + + nc2h2 = pc2h2 / kbz / temp + rstar = 2. * sig3(temp) * vo1 / (rgp*temp*log(sat)) + gstar = 4. * nav * pi * (rstar**3) / (3.*vo1) +c Loop over size bins + do i=1,nbin + x = aerad(i) / rstar + x = aerad(imono) / rstar ! r(5)=monomere + fistar = (4./3.*pi) * sig3(temp) * (rstar**2.) + & *fshape3(mtetac2h2,x) + deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp) + & , -100.), 100.) + if (deltaf.eq.-100.) then + nucrate(i) = 0. + else + zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) ) + nucrate(i) = zeldov * kbz* temp * rstar**2. + & * 4. * pi * ( nc2h2*aerad(i) )**2. + & / ( fshape3(mtetac2h2,x) * nus * m0 ) + & * dexp(deltaf) + + + if(i.gt.imono) nucrate(i)= zeldov * kbz* temp * rstar**2. + & * 4. * pi * vrat_e**(i-imono)*(nc2h2*aerad(imono) )**2. + & / (fshape3(mtetac2h2,x) * nus * m0 ) + & * dexp(deltaf) + + endif + enddo + ELSE + do i=1,nbin + nucrate(i) = 0. + enddo + + ENDIF + + return + end + +****************************************************************** + subroutine c2h2sat(t,p,qsat) +* * +* cette fonction calcule la pression de vapeur saturante de l' * +* ethane a une altitude donnee z par Reid et al., p657 * +* * +* Compatible avec Barth et al., dans l'intervalle 30-90K * +* * +* * +****************************************************************** + + real rgp + data rgp/8.3143/ + +* declaration des variables internes +* ---------------------------------- + + real qsat,t,p + + + a=-6.90128 + b=1.26873 + c=-2.09113 + d=-2.75601 + pc=61.4*1.013e5 + tc=308.3 + + x=(1.-t/tc) + if(x.gt. 0.) qsat=(1-x)**(-1)*(a*x+b*x**1.5+c*x**3.+d*x**6.) + if(x.le. 0.) qsat=a*x/abs(1.-x) ! approx pour t > tc + qsat=pc*exp(qsat) + + qsat=qsat* 26.0 / (28.0*p) ! kg/kg + + return + end + +c======================================================================= + subroutine growthrate3(timestep,temp,press,pc2h2,sat,seq,r,Cste) +c +c Determination of the droplet growth rate +c +c======================================================================= + + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c----------------------------------------------------------------------- +C DECLARATIONS: +c ------------- + + common/lheat/Lv + +c +c arguments: +c ---------- + + REAL timestep + REAL temp ! temperature in the middle of the layer (K) + REAL press ! pressure in the middle of the layer (K) + REAL*8 pc2h2 ! Methane vapor partial pressure (Pa) + REAL*8 sat ! saturation ratio + REAL r ! crystal radius before condensation (m) + REAL seq ! Equilibrium saturation ratio + +c local: +c ------ + + REAL psat + REAL moln2,molc2h2 + REAL To,tc2h2,wc2h2 ! Reid et al., (eq 7-9.4 + Appendix compound [168]) + REAL fte + +c Effective gas molecular radius (m) + data moln2/1.75e-10/ ! N2 +c Effective gas molecular radius (m) + data molc2h2/2.015e-10/ ! C2H2 +c Temperature critique + omega + data tc2h2/308.3/ + data wc2h2/19.0e-2/ + + REAL k,Lv + REAL knudsen ! Knudsen number (gas mean free path/particle radius) + REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate + REAL*8 Cste + +c----------------------------------------------------------------------- +c Ice particle growth rate by diffusion/impegement of molecules +c r.dr/dt = (S-Seq) / (Seq*Rk+Rd) +c with r the crystal radius, Rk and Rd the resistances due to +c latent heat release and to vapor diffusion respectively +c----------------------------------------------------------------------- + + psat = pc2h2 / sat + +c - Thermal conductibility of N2 + + k = ( 2.857e-2 * temp - 0.5428 ) * 4.184e-3 + + +c - Latent heat of c2h2 (J.kg-1) + Lv =581.e3 ! eq (7-9.4) Reid et al. + fte=(1.-temp/tc2h2) + if (fte.le.1.e-3) fte=1.e-3 + Lv=8.314*tc2h2*(7.08*fte**0.354+10.95*wc2h2*fte**0.456)/26.e-3 + + + +c - Constant to compute gas mean free path +c l= (T/P)*a, with a = ( 0.707*8.31/(4*pi*molrad**2 * avogadro)) + + a = 0.707*rgp/(4 * pi* (moln2*1.e10)**2 * (nav*1.e-20)) + +c - Compute Dv, methane vapor diffusion coefficient +c accounting for both kinetic and continuum regime of diffusion, +c the nature of which depending on the Knudsen number. + + Dv = 1./3. * sqrt( 8*rgp*temp/(pi*Mc2h2) )* (kbz*1.e20) * temp/ + & (pi*press*(moln2*1.e10+molc2h2*1.e10)**2 * sqrt(1.+Mc2h2/Mn2)) + + knudsen = temp / press * a / r + lambda = (1.333+0.71/knudsen) / (1.+1./knudsen) + Dv = Dv / (1. + lambda * knudsen) + +c - Compute Rk + Rk = Lv**2 * rhoi_c2h2 * Mc2h2 / (k*rgp*temp**2.) +* print*,'Cste Rk :',Lv,k,rgp,t + +c - Compute Rd + Rd = rgp * temp *rhoi_c2h2 / (Dv*psat*Mc2h2) +* print*,'Cste Rd :',Dv,psat,Mc2h2 + +c - Compute: rdr/dt = Cste * (S-Seq) + Cste = 1. / (seq*Rk+Rd) +* print*,'Cste Cste :',seq,Rk,Rd + + + RETURN + END + + +********************************************************* + real function sig3(t) +* this function computes the surface tension (N.m) * +* between acethylene and air as a function of temp. * +********************************************************* + + real t + pc=61.4*1.01325e5 + tc=308.3 + tb=188.4 + tr=t/tc + tbr=tb/tc + if(t.gt.308.0) then + tr=308./tc + endif + + + + sig3=0.1196*(1.+(tbr*alog(pc/1.01325))/(1.-tbr))-0.279 + sig3=pc**(2./3.)*tc**(1./3.)*sig3*(1.-tr)**(11./9.) + sig3=sig3*1.e-8 + + return + end + +********************************************************* + real*8 function fshape3(cost,rap) +* function computing the f(m,x) factor * +* related to energy required to form a critical embryo * +********************************************************* + + implicit none + + real cost + real*8 rap + real*8 phi + real*8 a,b,c + + + phi = sqrt( 1. - 2.*cost*rap + rap**2 ) + a = 1. + ( (1.-cost*rap)/phi )**3 + b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3) + c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.) + + fshape3 = 0.5*(a+b+c) + + if (rap.gt.3000.) fshape3 = ((2.+cost)*(1.-cost)**2)/4. + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/n_ethane.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/n_ethane.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/n_ethane.F (revision 1643) @@ -0,0 +1,626 @@ + subroutine n_ethane(ngrid,nq,nbin, + * dt,pl,tl,aerad, + * q,qprime) + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c Arguments +c --------- + + integer ngrid,nq,nbin + + REAL dt ! physical time step (s) + REAL pl(ngrid,nz) ! pressure at each level (mbar) + REAL tl(ngrid,nz) ! temperature at each level (K) + REAL aerad(nbin) ! Radius array + +c Tracers : + REAL q(ngrid,nz,nq) ! tracer (kg/kg) + REAL qprime(ngrid,nz,nbin) ! tracer (kg/kg) + + +c Local variables +c --------------- + + integer ntyp + parameter (ntyp=3) + + real n_aer(nz,nbin,ntyp) + real c2h6vap(nz) + + integer itrac + integer ig,i,j,k,l,n ! Loop integers + integer ilay,iq + +c Treatment +c --------- + + DO ig = 1 , NGRID + +c Set up the aerosol array + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + n_aer(l,k,j) = max(q(ig,l,itrac),0.) + enddo + enddo + enddo + +c Set up the methane vapor array + do l = 1, nz + c2h6vap(l) = q(ig,l,nq) + enddo + + call nucleacond2(ngrid,nbin,dt,ig,pl,tl,aerad, + & n_aer,qprime,c2h6vap) + +c Update q arrays + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + q(ig,l,itrac) = n_aer(l,k,j) + enddo + enddo + enddo + +c Update methane vapor array + do l = 1, nz + q(ig,l,nq) = c2h6vap(l) + +c if(q(ig,l,nq).le.0.) print*,'in nuc2h6',ig,l, q(ig,l,nq) + + enddo + + ENDDO + + return + END + +**************************************************************** + subroutine nucleacond2(ngrid,nbin,dt,ig, + * pl,tl,aerad,n_aer,qprime,c2h6vap) +* * +* This routine updates species concentrations due * +* to both nucleation and condensation-induced variations. * +* Gain and loss rates associated to each one of these * +* processes are computed separately in other routines. * +* * +**************************************************************** + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + + integer ng,nalt + parameter(ng=1,nalt=llm) + + real lv + +* dejà évalué dans n_methane ! + REAL x1(nalt) + REAL x2(nalt) + REAL x3(nalt) + REAL icefrac(nalt) + REAL pmixch4(nalt) + REAL pmixc2h6(nalt) + REAL pmixn2(nalt) + + common/lheat/lv + common/mixing/x1,x2,x3,icefrac, + & pmixch4,pmixc2h6,pmixn2 + + + +c Arguments +c --------- + + integer ngrid,nbin + integer ig + integer ntyp + parameter (ntyp=3) + + real dt ! Global time step + real pl(ngrid,nz),tl(ngrid,nz) + real aerad(nbin) + real c2h6vap(nz) ! Methane vapor mass mixing ratio (kg/m3) + real c2h6vap_old + real n_aer(nz,nbin,ntyp) ! number concentrations of particle/each size bin + real qprime(ngrid,nz,nbin) ! tracer (kg/kg) + REAL total1(nz),total11(nz),total2(nz),total22(nz) + REAL dmsm,mtot + + + + + +c Local +c ----- + + integer i,j,k,l,n,iindice,iselec + + real dQc ! Amount of condensed methane (kg/m3) during timestep + real*8 sat_ratio ! Methane saturation ratio over liquid + real*8 sat_ratmix ! Methane saturation ratio over liquid + real*8 pc2h6 ! Methane partial pressure (Pa) + real qsat ! Methane mass mixing ratio at saturation (kg/kg of air) + real qsatmix ! Methane mass mixing ratio at saturation (kg/kg of air) + real*8 rate(nbin) ! Heterogeneous Nucleation rate (s-1) + real*8 elim + + real nsav(nbin,ntyp) + real dn(nbin,ntyp) + real rad(nbin) ! Radius of droplets in each size bin + real*8 gr(nbin) ! Growth rate in each bin + real radius ! Radius of droplets after growth + real Qs ! Mass of condensate required to reach saturation + real newsat + real vol(nbin) + + real press + real sig2,temp,seq(nbin) + real Ctot,up,dwn,newvap,gltot + + real temp0,temp1,temp2,last_temp + real qsat1,sat_ratio1,tempf(0:10),sat_ratiof(0:10) + real rho_a,cap + real tempref + real xtime,xtime_prime + + + +c Variables for latent heat release + real lw + data lw / 581.e+3/ + save lw + + +c Treatment +c --------- + do i = 1, nbin + vol(i) = 4./3. * pi * aerad(i)**3. + enddo + + do l = 1, nz + total1(l)=0. !solide + do k = 1, nbin + total1(l)=total1(l)+n_aer(l,k,2)*rhoi_c2h6 + enddo + total2(l)=c2h6vap(l) + enddo + + +c Start loop over heights + DO 100 l = 1, nz + + iindice=0 ! mettre l'indice à 0 + + temp = tl(ig,l) + press = pl(ig,l) + tempref=temp + +c Save the values of the particle arrays before condensation + do j = 1, ntyp + do i = 1, nbin + nsav(i,j) = n_aer(l,i,j) + enddo + enddo + + + 99 continue + + + call c2h6sat(temp,press,qsat) + qsatmix=qsat + +c quantité pmixc2h6(l) déjà calculé dans cnuages.F et passé dans un common +c qsat=pmixc2h6(l)*30.0 / (28.0*p) +c qsatmix=pmixc2h6(l)*30.0 / (28.0*p) + +c Get the partial presure of methane vapor and its saturation ratio + pc2h6 = c2h6vap(l) * (Mn2/Mc2h6) * press + sat_ratio = c2h6vap(l) / qsat + sat_ratmix = c2h6vap(l) / qsatmix + +c Get the rates of nucleation + call nuclea2(nbin,aerad,pc2h6,temp,sat_ratio,rate) + +c Get the growth rates of condensation/sublimation + up = c2h6vap(l) + dwn = 1. + Ctot = c2h6vap(l) + DO i = 1, nbin + + if (n_aer(l,i,3).eq.0) then + rad(i) = aerad(i) + else + rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) + + & qprime(ig,l,i)/n_aer(l,i,3) + & +vol(i))*0.75/pi)**(1./3.) + endif + + +* Equilibrium saturation ratio (due to curvature effect) + seq(i) = exp( 2.*sig2(temp)*Mc2h6 /(rhoi_c2h6*rgp*temp*rad(i))) + + call growthrate2(dt,temp,press,pc2h6, + & sat_ratmix,seq(i),rad(i),gr(i)) + up = up + dt * gr(i) * 4. * pi * rhoi_c2h6 * rad(i) * seq(i) + * * nsav(i,3) + dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_c2h6 * rad(i) / qsat + * * nsav(i,3) + Ctot= Ctot + rhoi_c2h6 * nsav(i,2) + + ENDDO + + newvap = min(up/dwn,Ctot) + newvap = max(newvap,0.) + + gltot = 0. + DO i = 1, nbin + gr(i) = gr(i) * ( newvap/qsat - seq(i) ) + if(nsav(i,2).le.0. .and. gr(i).le.0.) then + n_aer(l,i,2) = 0. + else + n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i) + * * n_aer(l,i,3) + if (n_aer(l,i,2).le.0.) then + n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3) + n_aer(l,i,2) = 0. + n_aer(l,i,3) = 0. + endif + gltot=n_aer(l,i,2)*rhoi_c2h6+gltot + endif + + ENDDO + +c Determine the mass of exchanged methane + + dQc = 0. + DO i = 1, nbin + dQc = dQc - rhoi_c2h6 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + +c Update the methane vapor mixing ratio implied by +c the cond/eva processes. + + +c Arrays resetted to their initial value before condensation + do j = 1, ntyp + do i = 1, nbin + dn(i,j) = n_aer(l,i,j) - nsav(i,j) + n_aer(l,i,j) = nsav(i,j) + enddo + enddo + +c Update the c arrays. +c nucleation & cond/eva tendencies added together. + + do i=1,nbin + elim = dt * rate(i) + n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim) + n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3) + n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1) + n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2) + if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0. + enddo + + dQc = 0. + DO i = 1, nbin + dQc = dQc - rhoi_c2h6 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + + + c2h6vap(l) = c2h6vap(l) + dQc + +100 CONTINUE + + do l = 1, nz + total11(l)=0. + do k = 1, nbin + total11(l)=total11(l)+n_aer(l,k,2)*rhoi_c2h6 + enddo + total22(l)=c2h6vap(l) + enddo + + return + end + + +******************************************************* +* * + subroutine nuclea2(nbin,aerad,pc2h6,temp,sat,nucrate) +* This subroutine computes the nucleation rate * +* as given in Pruppacher & Klett (1978) in the * +* case of water ice forming on a solid substrate. * +* Definition refined by Keese (jgr,1989) * +* * +******************************************************* + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer nbin + real aerad(nbin) + + real*8 nucrate(nbin) + real*8 pc2h6 + real temp + real*8 sat + + integer l,i + real*8 nc2h6 + real sig2 ! Water-ice/air surface tension (N.m) + real*8 rstar ! Radius of the critical germ (m) + real*8 gstar ! # of molecules forming a critical embryo + real*8 x ! Ratio rstar/radius of the nucleating dust particle + real fistar ! Activation energy required to form a critical embryo (J) + real*8 zeldov ! Zeldovitch factor (no dim) + real*8 fshape2 ! function defined at the end of the file + real*8 deltaf + + real nus + data nus/1.e+13/ ! Jump frequency of a molecule (s-1) + real m0 + data m0/4.983e-26/ ! Weight of a methane molecule (kg) + real vo1 +c data vo1/9.094e-29/ + data vo1/5.4746e-5/ ! Volume of 1 mole + real desorp + data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule) + real surfdif + data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule) + + IF (sat .GT. 1.) then ! minimum condition to activate nucleation + + nc2h6 = pc2h6 / kbz / temp + rstar = 2. * sig2(temp) * vo1 / (rgp*temp*log(sat)) + gstar = 4. * nav * pi * (rstar**3) / (3.*vo1) +c Loop over size bins + do i=1,nbin + x = aerad(i) / rstar + x = aerad(imono) / rstar ! r(5)=monomere + fistar = (4./3.*pi) * sig2(temp) * (rstar**2.) + & *fshape2(mtetac2h6,x) + deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp) + & , -100.), 100.) + if (deltaf.eq.-100.) then + nucrate(i) = 0. + else + zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) ) + nucrate(i) = zeldov * kbz* temp * rstar**2. + & * 4. * pi * ( nc2h6*aerad(i) )**2. + & / ( fshape2(mtetac2h6,x) * nus * m0 ) + & * dexp(deltaf) + if(i.gt.imono) nucrate(i)= zeldov * kbz* temp * rstar**2. + & * 4. * pi * vrat_e**(i-imono)*(nc2h6*aerad(imono) )**2. + & / (fshape2(mtetac2h6,x) * nus * m0 ) + & * dexp(deltaf) + + endif + enddo + ELSE + do i=1,nbin + nucrate(i) = 0. + enddo + + ENDIF + + return + end + +****************************************************************** + subroutine c2h6sat(t,p,qsat) +* * +* cette fonction calcule la pression de vapeur saturante de l' * +* ethane a une altitude donnee z par Reid et al., p657 * +* * +* Compatible avec Barth et al., dans l'intervalle 30-90K * +* * +* * +****************************************************************** + + real rgp + data rgp/8.3143/ + +* declaration des variables internes +* ---------------------------------- + + real qsat,t,p + +c qsat=10.01-1085.0/(t-0.561) +c qsat=10.**qsat/760.*1.e5 + + + a=-6.34307 + b=1.011630 + c=-1.19116 + d=-2.03539 + pc=48.8*1.e5 + tc=305.4 + + x=(1.-t/tc) + if(x.gt. 0.) qsat=(1-x)**(-1)*(a*x+b*x**1.5+c*x**3.+d*x**6.) + if(x.le. 0.) qsat=a*x/abs(1.-x) ! approx pour t > tc + qsat=pc*exp(qsat) + + qsat=qsat* 30.0 / (28.0*p) ! kg/kg + + return + end + +c======================================================================= + subroutine growthrate2(timestep,temp,press,pc2h6,sat,seq,r,Cste) +c +c Determination of the droplet growth rate +c +c======================================================================= + + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c----------------------------------------------------------------------- +C DECLARATIONS: +c ------------- + + common/lheat/Lv + + +c +c arguments: +c ---------- + + REAL timestep + REAL temp ! temperature in the middle of the layer (K) + REAL press ! pressure in the middle of the layer (K) + REAL*8 pc2h6 ! Methane vapor partial pressure (Pa) + REAL*8 sat ! saturation ratio + REAL r ! crystal radius before condensation (m) + REAL seq ! Equilibrium saturation ratio + +c local: +c ------ + + REAL psat + REAL moln2,molc2h6 + REAL To,tc2h6,wc2h6 ! Reid et al., (eq 7-9.4 + Appendix compound [168]) + REAL fte + +c Effective gas molecular radius (m) + data moln2/1.75e-10/ ! N2 +c Effective gas molecular radius (m) + data molc2h6/2.22e-10/ ! C2H6 +c Temperature critique + omega + data tc2h6/305.4/ + data wc2h6/9.9e-2/ + + REAL k,Lv + REAL knudsen ! Knudsen number (gas mean free path/particle radius) + REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate + REAL*8 Cste + +c----------------------------------------------------------------------- +c Ice particle growth rate by diffusion/impegement of molecules +c r.dr/dt = (S-Seq) / (Seq*Rk+Rd) +c with r the crystal radius, Rk and Rd the resistances due to +c latent heat release and to vapor diffusion respectively +c----------------------------------------------------------------------- + + psat = pc2h6 / sat + +c - Thermal conductibility of N2 + + k = ( 2.857e-2 * temp - 0.5428 ) * 4.184e-3 + + +c - Latent heat of c2h6 (J.kg-1) + Lv =581.e3 ! eq (7-9.4) Reid et al. + fte=(1.-temp/tc2h6) + if (fte.le.1.e-3) fte=1.e-3 + Lv=8.314*tc2h6*(7.08*fte**0.354+10.95*wc2h6*fte**0.456)/30.e-3 + + + +c - Constant to compute gas mean free path +c l= (T/P)*a, with a = ( 0.707*8.31/(4*pi*molrad**2 * avogadro)) + + a = 0.707*rgp/(4 * pi* (moln2*1.e10)**2 * (nav*1.e-20)) + +c - Compute Dv, methane vapor diffusion coefficient +c accounting for both kinetic and continuum regime of diffusion, +c the nature of which depending on the Knudsen number. + + Dv = 1./3. * sqrt( 8*rgp*temp/(pi*Mc2h6) )* (kbz*1.e20) * temp / + & (pi*press*(moln2*1.e10+molc2h6*1.e10)**2 * sqrt(1.+Mc2h6/Mn2) ) + + knudsen = temp / press * a / r + lambda = (1.333+0.71/knudsen) / (1.+1./knudsen) + Dv = Dv / (1. + lambda * knudsen) + +c - Compute Rk + Rk = Lv**2 * rhoi_c2h6 * Mc2h6 / (k*rgp*temp**2.) +c - Compute Rd + Rd = rgp * temp *rhoi_c2h6 / (Dv*psat*Mc2h6) + +c - Compute: rdr/dt = Cste * (S-Seq) + Cste = 1. / (seq*Rk+Rd) + + RETURN + END + + +********************************************************* + real function sig2(t) +* this function computes the surface tension (N.m) * +* between methane and air as a function of temp. * +* Eq (12-3-6 et 12-3-7 Reid et al.) +* +********************************************************* + + real t + + pc=48.8*1.01325e5 + tc=305.4 + tb=184.6 + tr=t/tc + tbr=tb/tc + if(t.gt.305.0) then + tr=305./tc + endif + + sig2=0.1196*(1.+(tbr*alog(pc/1.01325))/(1.-tbr))-0.279 + sig2=pc**(2./3.)*tc**(1./3.)*sig2*(1.-tr)**(11./9.) + sig2=sig2*1.e-8 + + + + +c sig2 = 21.157*((305.4-t)/(305.4-153.2))**(11./9.) +c sig2=sig2*1.e-4 +c +c if(t.gt.305.0) then +c sig2 = 21.157*((305.4-305.)/(305.4-153.2))**(11./9.) +c sig2=sig2*1.e-4 +c endif +c +c print*,t,sig2,sig3 + + return + end + +********************************************************* + real*8 function fshape2(cost,rap) +* function computing the f(m,x) factor * +* related to energy required to form a critical embryo * +********************************************************* + + implicit none + + real cost + real*8 rap + real*8 phi + real*8 a,b,c + + + phi = sqrt( 1. - 2.*cost*rap + rap**2 ) + a = 1. + ( (1.-cost*rap)/phi )**3 + b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3) + c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.) + + fshape2 = 0.5*(a+b+c) + + if (rap.gt.3000.) fshape2 = ((2.+cost)*(1.-cost)**2)/4. + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/n_methane.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/n_methane.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/n_methane.F (revision 1643) @@ -0,0 +1,578 @@ + subroutine n_methane(ngrid,nq,nbin, + * dt,pl,tl,aerad, + * q,qprime) + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c Arguments +c --------- + + integer ngrid,nq,nbin + + REAL dt ! physical time step (s) + REAL pl(ngrid,nz) ! pressure at each level (mbar) + REAL tl(ngrid,nz) ! temperature at each level (K) + REAL aerad(nbin) ! Radius array + +c Tracers : + REAL q(ngrid,nz,nq) ! tracer (kg/kg) + REAL qprime(ngrid,nz,nbin) ! tracer (kg/kg) + + +c Local variables +c --------------- + + integer ntyp + parameter (ntyp=3) ! 3 = 1 aerosol + 1 noyau + 1 glace + + real n_aer(nz,nbin,ntyp) + real ch4vap(nz) + + integer itrac + integer ig,i,j,k,l,n ! Loop integers + integer ilay,iq + +c Treatment +c --------- + + DO ig = 1 , NGRID + +c Set up the aerosol array + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + n_aer(l,k,j) = max(q(ig,l,itrac),0.) + enddo + enddo + enddo + +c Set up the methane vapor array + do l = 1, nz + ch4vap(l) = q(ig,l,nq) + enddo + + + + call nucleacond(ngrid,nbin,dt,ig,pl,tl,aerad, + & n_aer,qprime,ch4vap) + + +c Update q arrays + do j = 1, ntyp + do k = 1, nbin + itrac = (j-1) * nbin + k + do l = 1, nz + q(ig,l,itrac) = n_aer(l,k,j) + enddo + enddo + enddo + +c Update methane vapor array + do l = 1, nz + q(ig,l,nq) = ch4vap(l) + enddo + + ENDDO + + return + END + +**************************************************************** + subroutine nucleacond(ngrid,nbin,dt,ig, + & pl,tl,aerad,n_aer,qprime,ch4vap) +* * +* This routine updates species concentrations due * +* to both nucleation and condensation-induced variations. * +* Gain and loss rates associated to each one of these * +* processes are computed separately in other routines. * +* * +**************************************************************** + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer ng,nalt + parameter(ng=1,nalt=llm) + + real lv + common/lheat/lv + +c Arguments +c --------- + + integer ngrid,nbin + integer ig + integer ntyp + parameter (ntyp=3) + + real dt ! Global time step + real pl(ngrid,nz),tl(ngrid,nz) + real aerad(nbin) + real ch4vap(nz) ! Methane vapor mass mixing ratio (kg/m3) + real ch4vap_old + real n_aer(nz,nbin,ntyp) ! number concentrations of particle/each size bin + real qprime(ngrid,nz,nbin) ! tracer (kg/kg) + REAL total1(nz),total11(nz),total2(nz),total22(nz) + REAL dmsm,mtot + + +c Local +c ----- + + integer i,j,k,l,n,iindice,iselec + + real dQc ! Amount of condensed methane (kg/m3) during timestep + real*8 sat_ratio ! Methane saturation ratio over liquid + real*8 sat_ratmix ! Methane saturation ratio over liquid + real*8 pch4 ! Methane partial pressure (Pa) + real qsat ! Methane mass mixing ratio at saturation (kg/kg of air) + real qsatmix ! Methane mass mixing ratio at saturation (kg/kg of air) + real*8 rate(nbin) ! Heterogeneous Nucleation rate (s-1) + real*8 elim + + real nsav(nbin,ntyp) + real dn(nbin,ntyp) + real rad(nbin) ! Radius of droplets in each size bin + real*8 gr(nbin) ! Growth rate in each bin + real radius ! Radius of droplets after growth + real Qs ! Mass of condensate required to reach saturation + real newsat + real vol(nbin) + + real press + real sig,temp,seq(nbin) + real Ctot,up,dwn,newvap,gltot + + real rho_a,cap + real tempref + real frac + real xtime,xtime_prime + real dQc2 + +c Variables for latent heat release + real lw + data lw / 510.e+3/ + save lw + + +c Treatment +c --------- + +c Treatment +c --------- + do i = 1, nbin + vol(i) = 4./3. * pi * aerad(i)**3. + enddo + + do l = 1, nz + total1(l)=0. !solide + do k = 1, nbin + total1(l)=total1(l)+n_aer(l,k,2)*rhoi_ch4 + enddo + total2(l)=ch4vap(l) + enddo + +c Start loop over heights + DO 100 l = 1, nz + + iindice=0 ! mettre l'indice à 0 + + temp = tl(ig,l) + press = pl(ig,l) + tempref=temp + +c Save the values of the particle arrays before condensation + do j = 1, ntyp + do i = 1, nbin + nsav(i,j) = n_aer(l,i,j) + enddo + enddo + + + 99 continue ! DEBUT DE LA BOUCLE CONDITONNELLE + + call ch4sat(temp,press,qsat) + qsat=qsat*0.85 + qsatmix=qsat*0.85 + +c Get the partial presure of methane vapor and its saturation ratio + pch4 = ch4vap(l) * (Mn2/Mch4) * press + sat_ratio = ch4vap(l) / qsat + sat_ratmix = ch4vap(l) / qsatmix + +c Get the rates of nucleation + call nuclea(nbin,aerad,pch4,temp,sat_ratio,rate) + +c Get the growth rates of condensation/sublimation + up = ch4vap(l) + dwn = 1. + Ctot = ch4vap(l) + DO i = 1, nbin + + if (n_aer(l,i,3).eq.0) then + rad(i) = aerad(i) + else + rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) + + & qprime(ig,l,i)/n_aer(l,i,3) + & +vol(i))*0.75/pi)**(1./3.) + endif + + +* Equilibrium saturation ratio (due to curvature effect) + seq(i) = exp( 2.*sig(temp)*Mch4 / (rhoi_ch4*rgp*temp*rad(i)) ) + + call growthrate(dt,temp,press,pch4, + & sat_ratmix,seq(i),rad(i),gr(i)) + up = up + dt * gr(i) * 4. * pi * rhoi_ch4 * rad(i) * seq(i) + * * nsav(i,3) + dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_ch4 * rad(i) / qsat + * * nsav(i,3) + Ctot= Ctot + rhoi_ch4 * nsav(i,2) + + ENDDO + + newvap = min(up/dwn,Ctot) + newvap = max(newvap,0.) + + gltot=0. + DO i = 1, nbin + gr(i) = gr(i) * ( newvap/qsat - seq(i) ) + if(nsav(i,2).le.0. .and. gr(i).le.0.) then + n_aer(l,i,2) = 0. + else + n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i) + * * n_aer(l,i,3) + if (n_aer(l,i,2).le.0.) then + n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3) + n_aer(l,i,2) = 0. + n_aer(l,i,3) = 0. + endif + gltot=n_aer(l,i,2)*rhoi_ch4+gltot + endif + + ENDDO + +c Determine the mass of exchanged methane + + dQc = 0. + DO i = 1, nbin + dQc = dQc - rhoi_ch4 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + + +c Arrays resetted to their initial value before condensation + + do j = 1, ntyp + do i = 1, nbin + dn(i,j) = n_aer(l,i,j) - nsav(i,j) + n_aer(l,i,j) = nsav(i,j) + enddo + enddo + + +c Update the c arrays. +c nucleation & cond/eva tendencies added together. + + do i=1,nbin + elim = dt * rate(i) + n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim) + n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3) + n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1) + n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2) + if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0. + + enddo + + dQc = 0. + DO i = 1, nbin ! dQc <0 si glace produite !! + dQc = dQc - rhoi_ch4 * ( n_aer(l,i,2) - nsav(i,2) ) + ENDDO + + + ch4vap(l) = ch4vap(l) + dQc + +100 CONTINUE + + do l = 1, nz + total11(l)=0. + do k = 1, nbin + total11(l)=total11(l)+n_aer(l,k,2)*rhoi_ch4 + enddo + total22(l)=ch4vap(l) + enddo + + + return + end + + +******************************************************* +* * + subroutine nuclea(nbin,aerad,pch4,temp,sat,nucrate) +* This subroutine computes the nucleation rate * +* as given in Pruppacher & Klett (1978) in the * +* case of water ice forming on a solid substrate. * +* Definition refined by Keese (jgr,1989) * +* * +******************************************************* + + implicit none +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + integer nbin + real aerad(nbin) + + real*8 nucrate(nbin) + real*8 pch4 + real temp + real*8 sat + + integer l,i + real*8 nch4 + real sig ! Water-ice/air surface tension (N.m) + real*8 rstar ! Radius of the critical germ (m) + real*8 gstar ! # of molecules forming a critical embryo + real*8 x ! Ratio rstar/radius of the nucleating dust particle + real fistar ! Activation energy required to form a critical embryo (J) + real*8 zeldov ! Zeldovitch factor (no dim) + real*8 fshape ! function defined at the end of the file + real*8 deltaf + + real nus + data nus/1.e+13/ ! Jump frequency of a molecule (s-1) + real m0 + data m0/2.6578e-26/ ! Weight of a methane molecule (kg) + real vo1 +c data vo1/6.254e-29/ ! Volume of a methane molecule (m3) + data vo1/3.7649e-5/ ! Volume of a methane molecule (m3) + + real desorp + data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule) + real surfdif + data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule) + + IF (sat .GT. 1.) THEN ! minimum condition to activate nucleation + + nch4 = pch4 / kbz / temp + rstar = 2. * sig(temp) * vo1 / (rgp*temp*log(sat)) + gstar = 4. * nav * pi * (rstar**3) / (3.*vo1) +c Loop over size bins + do i=1,nbin + x = aerad(i) / rstar + x = aerad(imono) / rstar ! attention r(5)=monomeres + + fistar = (4./3.*pi) * sig(temp) * (rstar**2.) * + & fshape(mtetach4,x) + deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp) + & , -100.), 100.) + if (deltaf.eq.-100.) then + nucrate(i) = 0. + else + zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) ) + nucrate(i) = zeldov * kbz* temp * rstar**2. + & * 4. * pi * ( nch4*aerad(i) )**2. + & / ( fshape(mtetach4,x) * nus * m0 ) + & * dexp(deltaf) + + if(i.gt.imono) nucrate(i)= zeldov * kbz* temp * rstar**2. + & * 4. * pi * vrat_e**(i-imono)*(nch4*aerad(imono) )**2. + & / (fshape(mtetach4,x) * nus * m0 ) + & * dexp(deltaf) + + + endif + enddo + ELSE + do i=1,nbin + nucrate(i) = 0. + enddo + + ENDIF + + return + end + +****************************************************************** + subroutine ch4sat(t,p,qsat) +* cette fonction calcule la pression de vapeur saturante du * +* methane a une altitude donnee z par l'equation de Thek-Stiel * +****************************************************************** + + real rgp + data rgp/8.3143/ + +* declaration des variables internes +* ---------------------------------- + real p,tc,pc,tr,tb,tbr,phib,ac,hbr,hvb,avb,a,b + real qsat + + tc = 190.53 + pc = 45.96 * 0.986923 + tr = t / tc + tb = 111.63 + tbr= tb / tc + phib = -35. + 36./tbr + 42.*log(tbr)-tbr**6 + ac = (0.315*phib + log(pc))/(0.0838*phib-log(tbr)) + hbr = tbr * log(pc) / (1.-tbr) + hvb = rgp*tb*(0.4343*log(pc)-0.68859+0.89584*tbr)/(0.37691- + s 0.37306*tbr+0.14878/(pc*tbr**2)) + avb = hvb / (rgp*tc*(1.-tbr)**(0.375)) + a = 5.2691 + 2.0753*avb - 3.1738*hbr + b = 1.042 * ac - 0.46284 * avb + + qsat=pc*exp(avb*(1.14893-1./tr-0.11719*tr-0.03174*tr**2 + s -0.375*log(tr))+b*((tr**a-1.)/a+0.04*(1./tr-1.))) + qsat=qsat*1e+5/0.986923 + ! ---> qsat en Pa + + qsat=qsat* 16.0 / (28.0*p) ! kg/kg + + + + return + end + +c======================================================================= + subroutine growthrate(timestep,temp,press,pch4,sat,seq,r,Cste) +c +c Determination of the droplet growth rate +c +c======================================================================= + + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + common/lheat/Lv + +c +c arguments: +c ---------- + + REAL timestep + REAL temp ! temperature in the middle of the layer (K) + REAL press ! pressure in the middle of the layer (K) + REAL*8 pch4 ! Methane vapor partial pressure (Pa) + REAL*8 sat ! saturation ratio + REAL r ! crystal radius before condensation (m) + REAL seq ! Equilibrium saturation ratio + +c local: +c ------ + + REAL psat + REAL moln2,molch4 + REAL To,wch4,tch4,ftm + +c Effective gas molecular radius (m) + data moln2/1.75e-10/ ! N2 +c Effective gas molecular radius (m) + data molch4/2.e-10/ ! CH4 + + data tch4/190.4/ + data wch4/1.1e-2/ ! Reid et al (Eq 7-9.4 + Appendix Compound [116]) + + REAL k,Lv + REAL knudsen ! Knudsen number (gas mean free path/particle radius) + REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate + REAL*8 Cste + +c----------------------------------------------------------------------- +c Ice particle growth rate by diffusion/impegement of molecules +c r.dr/dt = (S-Seq) / (Seq*Rk+Rd) +c with r the crystal radius, Rk and Rd the resistances due to +c latent heat release and to vapor diffusion respectively +c----------------------------------------------------------------------- + + psat = pch4 / sat + +c - Thermal conductibility of N2 + k = ( 2.857e-2 * temp - 0.5428 ) * 4.184e-3 +c - Latent heat of ch4 (J.kg-1) + Lv = 510.e+3 + ftm=1.-temp/tch4 + if (ftm.le.1.e-3) ftm=1.e-3 + Lv=8.314*tch4*(7.08*ftm**0.354+10.95*wch4*ftm**0.456)/16.e-3 + + +c - Constant to compute gas mean free path +c l= (T/P)*a, with a = ( 0.707*8.31/(4*pi*molrad**2 * avogadro)) + + a = 0.707*rgp/(4 * pi* (moln2*1.e10)**2 * (nav*1.e-20)) + +c - Compute Dv, methane vapor diffusion coefficient +c accounting for both kinetic and continuum regime of diffusion, +c the nature of which depending on the Knudsen number. + + Dv = 1./3. * sqrt( 8*rgp*temp/(pi*Mch4) )* (kbz*1.e20) * temp / + & (pi*press*(moln2*1.e10+molch4*1.e10)**2 * sqrt(1.+Mch4/Mn2) ) + + knudsen = temp / press * a / r + lambda = (1.333+0.71/knudsen) / (1.+1./knudsen) + Dv = Dv / (1. + lambda * knudsen) + +c - Compute Rk + Rk = Lv**2 * rhoi_ch4 * Mch4 / (k*rgp*temp**2.) +c - Compute Rd + Rd = rgp * temp *rhoi_ch4 / (Dv*psat*Mch4) + +c - Compute: rdr/dt = Cste * (S-Seq) + Cste = 1. / (seq*Rk+Rd) + + RETURN + END + + +********************************************************* + real function sig(t) +* this function computes the surface tension (N.m) * +* between methane and air as a function of temp. * +********************************************************* + + real t + + sig = ( t/4. + 41.) * 1e-3 + + return + end + +********************************************************* + real*8 function fshape(cost,rap) +* function computing the f(m,x) factor * +* related to energy required to form a critical embryo * +********************************************************* + + implicit none + + real cost + real*8 rap + real*8 phi + real*8 a,b,c + + phi = sqrt( 1. - 2.*cost*rap + rap**2 ) + + a = 1. + ( (1.-cost*rap)/phi )**3 + b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3) + c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.) + + fshape = 0.5*(a+b+c) + + if (rap.gt.3000.) fshape = ((2.+cost)*(1.-cost)**2)/4. + + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/numchimrad.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/numchimrad.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/numchimrad.h (revision 1643) @@ -0,0 +1,8 @@ +c----------------------------------------------------------------------- +c INCLUDE numchimrad.h + + COMMON/numchimrad/iradch4,iradc2h2,iradc2h6,iradhcn,iradn2,iradh2 + + INTEGER iradch4,iradc2h2,iradc2h6,iradhcn,iradn2,iradh2 + +c----------------------------------------------------------------------- Index: trunk/LMDZ.TITAN.old/libf/phytitan/optci.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optci.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optci.F (revision 1643) @@ -0,0 +1,323 @@ + SUBROUTINE OPTCI(ykim,qaer,nmicro,IPRINT) + use dimphy + use infotrac_phy, only: nqtot + use common_mod, only:rmcbar,xfbar,ncount,TauHID,TauCID,TauGID + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON +#include "dimensions.h" +#include "microtab.h" +#include "numchimrad.h" +#include "clesphys.h" + +c Arguments: +c --------- + REAL ykim(klon,klev,nqtot) + real qaer(klon,klev,nqtot) + integer nmicro,IPRINT +c --------- + +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + COMMON /STRAT2/ HCN(NLAYER) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /TAUS/ TAUHI(ngrid,NSPECI),TAUCI(ngrid,NSPECI), + & TAUGI(ngrid,NSPECI),TAURV(ngrid,NSPECV), + & TAUHV(ngrid,NSPECV),TAUCV(ngrid,NSPECV), + & TAUGV(ngrid,NSPECV) + + COMMON /OPTICI/ DTAUI(ngrid,NLAYER,NSPECI) + & ,TAUI (ngrid,NLEVEL,NSPECI) + & ,WBARI(ngrid,NLAYER,NSPECI) + & ,COSBI(ngrid,NLAYER,NSPECI) + & ,DTAUIP(ngrid,NLAYER,NSPECI) + & ,TAUIP(ngrid,NLEVEL,NSPECI) + & ,WBARIP(ngrid,NLAYER,NSPECI) + & ,COSBIP(ngrid,NLAYER,NSPECI) + + COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI), + & DWNI(NSPECI), WLNI(NSPECI) + + REAL DTAUP(ngrid,NLAYER,NSPECI),DTAUPP(ngrid,NLAYER,NSPECI) + COMMON /IRTAUS/ DTAUP,DTAUPP + + COMMON /part/v,rayon,vrat,dr,dv + + DIMENSION PROD(NLEVEL) +* nrad dans microtab.h + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + real xv1(klev,nspeci),xv2(klev,nspeci) + real xv3(klev,nspeci) + REAL QF1(nrad,NSPECI),QF2(nrad,NSPECI) + REAL QF3(nrad,NSPECI),QF4(nrad,NSPECI) + REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI) + REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI) + real emu + REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 + + integer iopti,iwarning ! iopti: premier appel, une seule boucle sur les l.d'o. + integer ig,seulmtunpt,iout + save iopti,iwarning,seulmtunpt + data iopti,iwarning,seulmtunpt/0,0,0/ + + real zqaer_1pt(NLAYER,2*nrad) +#include "optci_1pt.h" + + character*100 dummy + real dummy2,dummy3 + +C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS +C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF. +C +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C + print*,'START OPTCI' + +c Diagnostic eventuellement: +c if (nmicro.gt.0) then +c sum=0. +c do nng=2,klon +c do i=1,klev +c do j=1,nmicro +c print*,'j,rj',j,rayon(j) +c print*,'paer',qaer(nng,i,j) +c sum=sum+qaer(nng,i,j)*rayon(j)**3.*1.3333*3.1415*1000. +c enddo +c enddo +c enddo +c print*,sum/(klon-1),'SOMME COLONNE/OPTCI' +c endif + + +c do inq=1,nrad +c print*,inq,rayon(inq),vrat,qaer(12,25,inq) +c enddo + +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c INITIALISATIONS UNE SEULE FOIS +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (iopti.eq.0) then + +c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqtot=1, +c il faut quand meme qu on lise la look-up table de dim nrad=10 +c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h) +c +c Nouvelle verif pour nuages : +c La condition ci-dessus n'est plus realisable ! +c nmicro comprend maintenant aussi des glaces +c Donc on teste juste que nmicro soit > 2*nrad (ou nrad si on ne fait pas de nuages) + if (microfi.ge.1) then + if ((clouds.eq.1).and.(nmicro.lt.2*nrad)) then + print*,"OPTCI :" + print*,"clouds = 1 MAIS nmicro < 2*nrad" + print*,"Probleme pour zqaer_1pt dans optci." + stop + endif + if ((clouds.eq.0).and.(nmicro.lt.nrad)) then + print*,"OPTCI :" + print*,"nmicro < nrad" + print*,"Probleme pour zqaer_1pt dans optci." + stop + endif + endif + + DO 420 K=1,NSPECI +C LETS USE THE THOLIN OPTICAL CONSTANTS FOR THE HAZE. +c CALL THOLIN(WLNI(K),TNR,TNI) + CALL THOLIN_CVD(WLNI(K),TNR,TNI) + REALI(K)=TNR + XIMGI(K)=TNI*FHIR +C SET UP THE OPTICAL CONSTANTS FOR THE CLOUD + CALL LIQCH4(WLNI(K),TNR,TNI) + RCLDI(K)=TNR + XICLDI(K)=TNI + CALL LIQC2H6(WLNI(K),TNR,TNI) + RCLDI2(K)=TNR + XICLDI2(K)=TNI + 420 CONTINUE + +c DEBUG +c print*,"wnoi=",WNOI + +C +C ZERO ALL OPTICAL DEPTHS. +C ??FLAG? FOR SOME APPLCIATIONS THE TOP OPACITY MAY NOT VANISH + +c open (unit=1,file='xsetupi') +c do i=1,klev +c read(1,*) a +c do j=1,nspeci +c read(1,*) xv1(i,j),xv2(i,j),xv3(i,j) +c enddo +c enddo +c close(1) + + endif ! fin initialisations premier appel + +c************************************************************************ +c************************************************************************ + DO 79 ig=1,klon ! BOUCLE SUR GRILLE HORIZONTALE +c print*,'ig NEW optci',ig +c************************************************************************ +c************************************************************************ + + if (.not.ylellouch) then + + XN2(1) = ykim(ig,1,iradn2) + CH4(1) = ykim(ig,1,iradch4) + H2(1) = ykim(ig,1,iradh2) + do j=2,nlayer + XN2(j) = (ykim(ig,j,iradn2)+ykim(ig,j-1,iradn2))/2. + CH4(j) = (ykim(ig,j,iradch4)+ykim(ig,j-1,iradch4))/2. + H2(j) = (ykim(ig,j,iradh2)+ykim(ig,j-1,iradh2))/2. + enddo + XN2(nlevel) = ykim(ig,nlayer,iradn2) + CH4(nlevel) = ykim(ig,nlayer,iradch4) + H2(nlevel) = ykim(ig,nlayer,iradh2) + + do j=1,nlayer + emu = ( xmu(j) + xmu(j+1) )/2. + C2H2(j) = ykim(ig,j,iradc2h2) * 26./emu + C2H6(j) = ykim(ig,j,iradc2h6) * 30./emu + HCN(j) = ykim(ig,j,iradhcn ) * 27./emu + enddo + + endif + +c if ((.not.ylellouch).and.(ig.eq.klon/2)) then +c print*,' LAYER C2H2 C2H6 HCN masmix ratios' +c do j=1,nlayer +c print*,j,C2H2(j),C2H6(j),HCN(j) +c enddo +c endif + + if (microfi.ge.1) then + do iq=1,2*nrad +c si on ne fait pas de nuages on ne copie que les nrad premieres valeurs. + if (clouds.eq.0.and.iq.gt.nrad) then + zqaer_1pt(:,iq)=0. + else + do j=1,NLAYER + zqaer_1pt(j,iq)=qaer(ig,j,iq) + enddo + endif + enddo + else + if (ig.eq.1) then + zqaer_1pt = 0. +c initialisation zqaer_1pt a partir d une look-up table (uniforme en ig) +c boucle sur nrad=10 (dans microtab.h) + open(10,file="qaer_eq_1d.dat") + do iq=1,15 + read(10,'(A100)') dummy + enddo + do j=NLAYER,1,-1 + read(10,*) dummy2,dummy3,(zqaer_1pt(j,iq),iq=1,nrad) + enddo + close(10) +c ici, les tableaux definissant la structure des aerosols sont +c remplis: rf,df(nq),rayon(nq,)v(nq)...... + call rdf() + endif + endif + +c if ((ig.eq.klon/2).or.(microfi.eq.0)) then +c print*,"Q01=",zqaer_1pt(:,1) +c print*,"Q05=",zqaer_1pt(:,5) +c print*,"Q10=",zqaer_1pt(:,10) +c stop +c endif + + iout=0 +c if ((microfi.eq.0).or.(ig.eq.(klon/2+16))) iout=1 + if (seulmtunpt.eq.0) then + call optci_1pt3(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:), + & iopti,iout) + iopti = 1 + endif + +c Pas de microphysique, ni de composition variable: un seul passage +c dans optci_1pt. + if ((microfi.eq.0).and.(ylellouch)) then + seulmtunpt = 1 + endif + + COSBI(ig,:,:) = MAX(MIN(COSBI_1pt(:,:),0.999999),1e-6) + WBARI(ig,:,:) = MAX(MIN(WBARI_1pt(:,:),0.999999),1e-6) + DTAUI(ig,:,:) = DTAUI_1pt(:,:) + TAUI(ig,:,:) = TAUI_1pt(:,:) + + COSBIP(ig,:,:) = MAX(MIN(COSBIP_1pt(:,:),0.999999),1e-6) + WBARIP(ig,:,:) = MAX(MIN(WBARIP_1pt(:,:),0.999999),1e-6) + DTAUIP(ig,:,:) = DTAUIP_1pt(:,:) + TAUIP(ig,:,:) = TAUIP_1pt(:,:) + + TAUHI(ig,:) = TAUHI_1pt(:) + TAUCI(ig,:) = TAUCI_1pt(:) + TAUGI(ig,:) = TAUGI_1pt(:) + + TauHID(ig,:,:) = TAUHID_1pt(:,:) + TauCID(ig,:,:) = TAUCID_1pt(:,:) + TauGID(ig,:,:) = TAUGID_1pt(:,:) + +c DEBUG +c if(ig.eq.(ngrid/2+16)) then +c print*,ig,'/',KLON,':' +c print*,'TauHID_1',TAUHID(ig,1,:) +c print*,'TauGID_1',TAUGID(ig,1,:) +c print*,'TauHID_50',TAUHID(ig,50,:) +c print*,'TauGID_50',TAUGID(ig,50,:) +c print*,"DTAUI_1=",DTAUI(ig,1,:) +c print*,"DTAUI_50=",DTAUI(ig,50,:) +c print*,'cosBI_1',COSBI(ig,1,:) +c print*,'cosBI_50',COSBI(ig,50,:) +c print*,'WBARI_1',WBARI(ig,1,:) +c print*,'WBARI_50',WBARI(ig,50,:) +c stop +c endif + +c************************************************************************ +c************************************************************************ + 79 CONTINUE ! FIN BOUCLE GRILLE HORIZONTALE +c************************************************************************ +c************************************************************************ +C THIS ROUTINE HAS ALREADY SET THE DTAUI(J,K) VALUES BUT MUST BE PASSED + DO 225 IG=1,klon + DO 220 J=1,NLAYER + DO 230 K=1,NSPECI + DTAUP(IG,J,K)=DTAUI(IG,J,K) + DTAUPP(IG,J,K)=DTAUIP(IG,J,K) +230 CONTINUE +220 CONTINUE +225 CONTINUE + + print*, 'FIN OPTCI' + + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.F (revision 1643) @@ -0,0 +1,502 @@ + SUBROUTINE optci_1pt(zqaer_1pt,rcdb,xfrb,iopti,IPRINT) + use dimphy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: RGAS +#include "dimensions.h" +#include "microtab.h" +#include "numchimrad.h" +#include "clesphys.h" + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,iopti +C iopti: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optci_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + COMMON /STRAT2/ HCN(NLAYER) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI), + & DWNI(NSPECI), WLNI(NSPECI) + + COMMON /part/v,rayon,vrat,dr,dv + + DIMENSION PROD(NLEVEL) +* nrad dans microtab.h + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + real xv1(klev,nspeci),xv2(klev,nspeci) + real xv3(klev,nspeci) + REAL QF1(nrad,NSPECI),QF2(nrad,NSPECI) + REAL QF3(nrad,NSPECI),QF4(nrad,NSPECI) + REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI) + REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI) + REAL QC1(nrad,NSPECI),QC2(nrad,NSPECI) + REAL QC3(nrad,NSPECI),QC4(nrad,NSPECI) + real emu + REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI) + +c ---- nuages + REAL TNUAGE,TNUAGESCAT + REAL rcdb(nlayer),xfrb(nlayer,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 + +C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS +C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF. +C +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C + + DO 80 K=1,NSPECI + TAUHI_1pt(K)=0. + TAUCI_1pt(K)=0. + TAUGI_1pt(K)=0. + 80 CONTINUE + +c************************************************************************ + DO 100 J=1,NLAYER ! BOUCLE SUR L'ALTITUDE +c************************************************************************ + +c print*,'ig,k,j ',ig,k,j + +C SET UP THE COEFFICIENT TO REDUCE MASS PATH TO STP ...SEE NOTES +C T0 =273.15 PO=1.01325 BAR + + TBAR=0.5*(TEMP(J)+TEMP(J+1)) + PBAR=SQRT(PRESS(J)*PRESS(J+1)) + BMU=0.5*(XMU(J+1)+XMU(J)) +c attention ici, Z en km doit etre passe en m + COEF1=RGAS*273.15**2*.5E5* (PRESS(J+1)**2 - PRESS(J)**2) + & /(1.01325**2 *EFFG(Z(J)*1000.)*TBAR*BMU) + + IF (IPRINT .GT. 9) WRITE(6,21) J,EFFG(Z(J)*1000.),TBAR,BMU,COEF1 + 21 FORMAT(' J, EFFG, TBAR, BMU, COEF1,: ',I3,1P6E10.3) + +c------------------------------------------------------------------------ + DO 101 K=1,NSPECI ! BOUCLE SUR LES L.D'O +c------------------------------------------------------------------------ + + +C #1: HAZE +C--------------------- + +C FIRST COMPUTE TAU AEROSOL + + +c +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (WNOI(K).lt.wco) THEN ! lamda > 56 um + + if (iopti.eq.0) then + +c CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), +c & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + + CALL CMIE(1.E-2/WNOI(K),REALI(K),XIMGI(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + + ELSE ! 0.2 < lambda < 56 um + + + if(rayon(inq).lt.RF(inq)) THEN + + if (iopti.eq.0) then + + CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), + & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + else + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + + if (iopti.eq.0) then + +c CALL OPTFRAC(XMONO,10000./WNOI(K) +c & ,QEXT,QSCT,QABS,QBAR) + + + CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + endif ! end iopti + + TAEROS=QF1(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq) + + endif + + IF(TAEROS.LT.1.e-10) TAEROS=1.e-10 + ENDIF + ENDDO ! FIN DE LA BOUCLE SUR nrad + + + + + CBAR=CBAR/TAEROSCAT + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*0.85 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*1.15 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1(K)=TAEROS + TAEROSCATM1(K)=TAEROSCAT + DELTAZM1(K)=DELTAZ + + + IF(TAEROSCAT.le.0.) CBAR=0. + +c print*,'HERE, MCKAY AEROSOLS IR' +c TAEROS=xv1(j,k) +c TAEROSCAT=xv2(j,k) +c CBAR=xv3(j,k) + +c if (ig.eq.1) then +c if (k.eq.NSPECV/2) then +c print*,'@IR',K,J,TAEROS,TAEROSCAT,CBAR +c stop'Pour faire des comparaisons' +c endif +c endif + + +c*********** EN TRAVAUX *************************** + +C #2: CLOUD +C------------------ + +C NEXT COMPUTE TAU CLOUD + IF (clouds.eq.0) THEN + TNUAGE=0. + TNUAGESCAT=0. + CNBAR=0. + ELSE + TNUAGE=0. + TNUAGESCAT=0. + CNBAR=0. + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + + DO inq=1,nrad !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS + QC1(inq,K)=0. + QC2(inq,K)=0. + QC3(inq,K)=0. + QC4(inq,K)=0. + ENDDO + +** OPTICAL CONSTANT : MIXING RULES + + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + + XNR=xfrb(nlayer+1-J,1) *REALI(K) + & +xfrb(nlayer+1-J,2) *RCLDI(K) + & +xfrb(nlayer+1-J,3) *RCLDI2(K) + & +xfrb(nlayer+1-J,4) *RCLDI2(K) + + XNI=xfrb(nlayer+1-J,1) *XIMGI(K) + & +xfrb(nlayer+1-J,2) *XICLDI(K) + & +xfrb(nlayer+1-J,3) *XICLDI2(K) + & +xfrb(nlayer+1-J,4) *XICLDI2(K) + +** OPTICAL CONSTANT : LIQUID DROP = THOLIN + + IF(xfrb(nlayer+1-J,1).ge.0.1) THEN + XNI=XIMGI(K) + XNR=REALI(K) + ENDIF + + IF (XNI.gt.1.e-10 .and. XNR.gt.1.00) THEN + CALL CMIE(1.E-2/WNOI(K),XNR,XNI, + & rcdb(nlayer+1-J), + & QEXTC,QSCTC,QABSC,CBARC) + ELSE + PRINT*,' WARNING XNR/XNI in optci: ',XNR,XNI + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + ENDIF + ELSE + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + ENDIF + + DO inq=1,nrad !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS + QC1(inq,K)=QEXTC/xnuf + QC2(inq,K)=QSCTC/xnuf + QC3(inq,K)=QABSC/xnuf + QC4(inq,K)=CBARC + TNUAGE=QC1(inq,K)*zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4 + & +TNUAGE + TNUAGESCAT=QC2(inq,K)*zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4 + & +TNUAGESCAT + CNBAR=QC4(inq,K)*QC2(inq,K) + & *zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4+CNBAR + ENDDO + + IF(TNUAGESCAT.EQ.0.) THEN + CNBAR=0. + ELSE + CNBAR=CNBAR/TNUAGESCAT + ENDIF + ENDIF ! Cond CLD + + +C #3: GAZ +C------------------ + +C NOW COMPUTE TAUGAS DUE TO THE PIA TERM ONLY FOR LAMDA LT 940 + TAUGAS=0.0 + IF (WNOI(K) .LT. 940. ) THEN +c if(ig.eq.1.and.k.eq.nspecv/2) print*,'avant PIA' + CALL PIA(K,TBAR,PNN,PCC,PCN,PHN) +c if(ig.eq.1.and.k.eq.nspecv/2) print*,'apres PIA' +C HERE IS WHERE WE COULD SCALE THE PIA COEFFICEINTS TO FIT DATA +C BASED ON REGIS' NOTES. ---TGM HAS THIS ADJUST IN IT AS DEFAULT + PCN=PCN*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C***REPLACE ABOVE WITH: PCN=PCN*1.25*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C 1.25 FACTOR (NOT FROM DATA) SUGGESTED BY TOON et al. (1988) + TAUGAS=COEF1* + & (XN2(J)*XN2(J)*PNN + CH4(J)*CH4(J)*PCC + & + XN2(J)*CH4(J)*PCN + XN2(J)*H2(J)*PHN) + IF (J .EQ. NLAYER .AND. IPRINT .GT. 9) + & WRITE (6,22) WNOI(K),TAUGAS,XN2(J),CH4(J),H2(J), + & TBAR, PNN,PCC,PCN, PHN, + & XN2(J)*XN2(J)*PNN , CH4(J)*CH4(J)*PCC , + & XN2(J)*CH4(J)*PCN , XN2(J)*H2(J)*PHN + 22 FORMAT(1X,1P8E10.2) + ENDIF + + IF (K .GT. 28) THEN + KGAS=K-28 +C ??FLAG? HERE MUST BE WATCHED CAREFULLY + U=COLDEN(J)*6.02204E23/BMU +c if(ig.eq.1.and.k.eq.nspecv/2) print*,'Avant GAS2' + if((ylellouch).or.(.not.hcnrad)) then + CALL GAS2_NOHCN(J, KGAS,TBAR,PBAR,U,TAU2) + else + CALL GAS2(J, KGAS,TBAR,PBAR,U,TAU2) + endif +c if(ig.eq.1.and.k.eq.nspecv/2) print*,'Apres GAS2' + TAUGAS=TAUGAS+TAU2 + ENDIF +C + + DTAUI_1pt(J,K)=TAUGAS+TAEROS+TNUAGE + DTAUIP_1pt(J,K)=TAUGAS+TAEROS + + TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS + TAUHID_1pt(J,K)=TAUHI_1pt(K) + + TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS + TAUGID_1pt(J,K)=TAUGI_1pt(K) + + TAUCI_1pt(K)=TAUCI_1pt(K) + TNUAGE + TAUCID_1pt(J,K)=TAUCI_1pt(K) + +C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE! + + TLIMIT=1.E-16 + + + IF (TAEROSCAT + TNUAGESCAT .GT. 0.) THEN + COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CNBAR*TNUAGESCAT ) + & /(TAEROSCAT + TNUAGESCAT) + ELSE + COSBI_1pt(J,K)=0.0 + ENDIF + + IF (TAEROSCAT .GT. 0.) THEN + COSBIP_1pt(J,K)=(CBAR*TAEROSCAT) + & /(TAEROSCAT) + ELSE + COSBIP_1pt(J,K)=0.0 + ENDIF + +*--------- + + IF (DTAUI_1pt(J,K) .GT. TLIMIT) THEN + WBARI_1pt(J,K)=(TAEROSCAT+TNUAGESCAT) /DTAUI_1pt(J,K) + ELSE + WBARI_1pt(J,K)=0.0 + DTAUI_1pt(J,K)=TLIMIT + ENDIF + + IF (DTAUIP_1pt(J,K) .GT. TLIMIT) THEN + WBARIP_1pt(J,K)=(TAEROSCAT) /DTAUIP_1pt(J,K) + ELSE + WBARIP_1pt(J,K)=0.0 + DTAUIP_1pt(J,K)=TLIMIT + ENDIF + + +c IF (IPRINT .GT. 9) +c & WRITE(6,73)J,K,TAUGAS,TAEROS,QEXT,QSCT + 73 FORMAT(2I3,1P8E10.3) + + +c------------------------------------------------------------------------ + 101 CONTINUE ! FIN BOUCLE L D'O +c------------------------------------------------------------------------ + + iopti=1 + +c************************************************************************ + 100 CONTINUE ! FIN BOUCLE ALTITUDE +c************************************************************************ + + DO 119 K=1,NSPECI + TAUI_1pt(1,K)=0.0 + TAUIP_1pt(1,K)=0.0 + DO 119 J=1,NLAYER + TAUI_1pt(J+1,K)=TAUI_1pt(J,K)+DTAUI_1pt(J,K) + TAUIP_1pt(J+1,K)=TAUIP_1pt(J,K)+DTAUIP_1pt(J,K) + 119 CONTINUE + +c IF (IPRINT .GT. 2) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE INFRARED') + +c DO 200 K=1,NSPECI ! #2 +c WRITE (6,190) +c WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K) +c & ,BWNI(K)+DWNI(K),DWNI(K) +c WRITE (6,230)REALI(K),XIMGI(K) + +c DO 195 J=1,NLAYER ! #3 +c WRITE (6,220)XNUMB(J), WBARI_1pt(J,K),COSBI_1pt(J,K) +c & , DTAUI_1pt(J,K),TAUI_1pt(J,K) +c 195 CONTINUE + +c IF(ig.eq.12) WRITE (6,240) TAUI_1pt(NLEVEL,K) +c 200 CONTINUE + +c END IF + + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU') +c 220 FORMAT(5(1X,G9.3)) +c 240 FORMAT(41X,G9.3) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt.h (revision 1643) @@ -0,0 +1,47 @@ +!---------------------------------------------- +! fichier optci_1p.h +! +! regroupe les sorties du fichier optci_1pt +! les nuages oblige a quasiment doubler +! le nombre de variables c'est juste pour +! la lisibilite. +!---------------------------------------------- + +! ----DIAGNOSTIQUES + real TAUHID_1pt(NLAYER,NSPECI) + real TAUCID_1pt(NLAYER,NSPECI) + real TAUGID_1pt(NLAYER,NSPECI) +! ----OPACITES TOTALES + real TAUHI_1pt(NSPECI) + real TAUCI_1pt(NSPECI) + real TAUGI_1pt(NSPECI) +! ----COLONNE NUAGEUSE + real DTAUI_1pt(NLAYER,NSPECI) + real TAUI_1pt(NLEVEL,NSPECI) + real WBARI_1pt(NLAYER,NSPECI) + real COSBI_1pt(NLAYER,NSPECI) +! ----COLONNE "CLAIRE" + real DTAUIP_1pt(NLAYER,NSPECI) + real TAUIP_1pt(NLEVEL,NSPECI) + real WBARIP_1pt(NLAYER,NSPECI) + real COSBIP_1pt(NLAYER,NSPECI) + + + common/opti_1pt/ & + & TAUHID_1pt & + & ,TAUCID_1pt & + & ,TAUGID_1pt & +! ----OPACITES TOTALES + & ,TAUHI_1pt & + & ,TAUCI_1pt & + & ,TAUGI_1pt & +! ----COLONNE NUAGEUSE + & ,DTAUI_1pt & + & ,TAUI_1pt & + & ,WBARI_1pt & + & ,COSBI_1pt & +! ----COLONNE "CLAIRE" + & ,DTAUIP_1pt & + & ,TAUIP_1pt & + & ,WBARIP_1pt & + & ,COSBIP_1pt Index: trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_2.F (revision 1643) @@ -0,0 +1,476 @@ + SUBROUTINE optci_1pt2(zqaer_1pt,rcdb,xfrb,iopti,IPRINT) + + use dimphy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: RGAS +#include "dimensions.h" +#include "microtab.h" +#include "numchimrad.h" +#include "clesphys.h" + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,iopti +C iopti: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optci_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + COMMON /STRAT2/ HCN(NLAYER) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI), + & DWNI(NSPECI), WLNI(NSPECI) + + COMMON /part/v,rayon,vrat,dr,dv + + DIMENSION PROD(NLEVEL) +* nrad dans microtab.h + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + real xv1(klev,nspeci),xv2(klev,nspeci) + real xv3(klev,nspeci) + REAL QF1(nrad,NSPECI),QF2(nrad,NSPECI) + REAL QF3(nrad,NSPECI),QF4(nrad,NSPECI) + REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI) + REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI) + REAL QC1(nrad,NSPECI),QC2(nrad,NSPECI) + REAL QC3(nrad,NSPECI),QC4(nrad,NSPECI) + real emu + REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI) + +c ---- nuages + REAL TNUAGE,TNUAGESCAT + REAL rcdb(nlayer),xfrb(nlayer,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4,qc1,qc2,qc3,qc4 + + +C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS +C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF. +C +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C + + DO 80 K=1,NSPECI + TAUHI_1pt(K)=0. + TAUCI_1pt(K)=0. + TAUGI_1pt(K)=0. + 80 CONTINUE + +c************************************************************************ + DO 100 J=1,NLAYER ! BOUCLE SUR L'ALTITUDE +c************************************************************************ + +C SET UP THE COEFFICIENT TO REDUCE MASS PATH TO STP ...SEE NOTES +C T0 =273.15 PO=1.01325 BAR + + TBAR=0.5*(TEMP(J)+TEMP(J+1)) + PBAR=SQRT(PRESS(J)*PRESS(J+1)) + BMU=0.5*(XMU(J+1)+XMU(J)) +c attention ici, Z en km doit etre passe en m + COEF1=RGAS*273.15**2*.5E5* (PRESS(J+1)**2 - PRESS(J)**2) + & /(1.01325**2 *EFFG(Z(J)*1000.)*TBAR*BMU) + + IF (IPRINT .GT. 9) WRITE(6,21) J,EFFG(Z(J)*1000.),TBAR,BMU,COEF1 + 21 FORMAT(' J, EFFG, TBAR, BMU, COEF1,: ',I3,1P6E10.3) + +c------------------------------------------------------------------------ + DO 101 K=1,NSPECI ! BOUCLE SUR LES L.D'O +c------------------------------------------------------------------------ + + +C #1: HAZE +C--------------------- + +C FIRST COMPUTE TAU AEROSOL + + +c +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (WNOI(K).lt.wco) THEN ! lamda > 56 um + + if (iopti.eq.0) then + +c CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), +c & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + CALL CMIE(1.E-2/WNOI(K),REALI(K),XIMGI(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + + ELSE ! 0.2 < lambda < 56 um + + + if(rayon(inq).lt.RF(inq)) THEN + + if (iopti.eq.0) then + + CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), + & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + else + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + + if (iopti.eq.0) then + + CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + endif ! end iopti + + TAEROS=QF1(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq) + + endif + + IF(TAEROS.LT.1.e-10) TAEROS=1.e-10 + + ENDIF + ENDDO ! FIN DE LA BOUCLE SUR nrad + + IF(TAEROSCAT.le.0.) then + CBAR=0. + ELSE + CBAR=CBAR/TAEROSCAT + ENDIF + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*0.85 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*1.15 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1(K)=TAEROS + TAEROSCATM1(K)=TAEROSCAT + DELTAZM1(K)=DELTAZ + + + IF(TAEROSCAT.le.0.) CBAR=0. + +c print*,'HERE, MCKAY AEROSOLS IR' +c TAEROS=xv1(j,k) +c TAEROSCAT=xv2(j,k) +c CBAR=xv3(j,k) + +c*********** EN TRAVAUX *************************** + +C #2: CLOUD +C------------------ +C NEXT COMPUTE TAU CLOUD +c +c Menu special : +c Afin d'eviter la surcharge de calcul on ne calcule les +c propriétes optiques des nuages qu'une seule fois +c avec un rayon de particule effectif de 3um et une composition +c de goutte : 90% CH4 / 10% NOYAUX +c Puis on ajute les section efficace par la surface reelle de +c la goutte. +c +c ---> A TESTER !!!! +c + TNUAGE=0. + TNUAGESCAT=0. + CNBAR=0. + IF (clouds.eq.1) THEN + IF (iopti.eq.0) THEN !--> au premier appel + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + DO inq=1,nrad !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS + QC1(inq,K)=0. + QC2(inq,K)=0. + QC3(inq,K)=0. + QC4(inq,K)=0. + ENDDO +** OPTICAL CONSTANT : MIXING RULES +** Fraction volumique fixe : +** 10% noyaux. +** 90% methane. + XNR = 0.5 * REALI(K) + & + 0.5 * RCLDI(K) + XNI = 0.5 * XIMGI(K) + & + 0.5 * XICLDI(K) +** +** Efficacite : particule de 3um de rayon + CALL CMIE(1.E-2/WNOI(K),XNR,XNI,3.e-6, + & QEXTC,QSCTC,QABSC,CBARC) +** +** ATTENTION CE SONT DES EFFICACITES : il faut les x par la surface REELLE de la goutte. + DO inq=1,nrad + QC1(inq,K)=QEXTC/xnuf + QC2(inq,K)=QSCTC/xnuf + QC3(inq,K)=QABSC/xnuf + QC4(inq,K)=CBARC + ENDDO + ENDIF ! iopti = 0 + +c ----- On ne calcule les constante optiques que si Rgoutte > 1e-10 + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + DO inq=1,nrad + TNUAGE=QC1(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4* + & zqaer_1pt(nlayer+1-J,inq+nrad) + + & TNUAGE + TNUAGESCAT=QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.* + & 1.e-4*zqaer_1pt(nlayer+1-J,inq+nrad) + + & TNUAGESCAT + CNBAR=QC4(inq,K)*QC2(inq,K)* + & (rcdb(nlayer+1-J)/3.e-6)**2.* + & 1.e-4*zqaer_1pt(nlayer+1-J,inq+nrad) + + & CNBAR + ENDDO + ENDIF + + IF(TNUAGESCAT.EQ.0.) THEN + CNBAR=0. + ELSE + CNBAR=CNBAR/TNUAGESCAT + ENDIF + + ENDIF ! Cond CLD +c +C #3: GAZ +C------------------ + +C NOW COMPUTE TAUGAS DUE TO THE PIA TERM ONLY FOR LAMDA LT 940 + TAUGAS=0.0 + IF (WNOI(K) .LT. 940. ) THEN + CALL PIA(K,TBAR,PNN,PCC,PCN,PHN) +C HERE IS WHERE WE COULD SCALE THE PIA COEFFICEINTS TO FIT DATA +C BASED ON REGIS' NOTES. ---TGM HAS THIS ADJUST IN IT AS DEFAULT + PCN=PCN*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C***REPLACE ABOVE WITH: PCN=PCN*1.25*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C 1.25 FACTOR (NOT FROM DATA) SUGGESTED BY TOON et al. (1988) + TAUGAS=COEF1* + & (XN2(J)*XN2(J)*PNN + CH4(J)*CH4(J)*PCC + & + XN2(J)*CH4(J)*PCN + XN2(J)*H2(J)*PHN) + IF (J .EQ. NLAYER .AND. IPRINT .GT. 9) + & WRITE (6,22) WNOI(K),TAUGAS,XN2(J),CH4(J),H2(J), + & TBAR, PNN,PCC,PCN, PHN, + & XN2(J)*XN2(J)*PNN , CH4(J)*CH4(J)*PCC , + & XN2(J)*CH4(J)*PCN , XN2(J)*H2(J)*PHN + 22 FORMAT(1X,1P8E10.2) + ENDIF + + IF (K .GT. 28) THEN + KGAS=K-28 +C ??FLAG? HERE MUST BE WATCHED CAREFULLY + U=COLDEN(J)*6.02204E23/BMU + if((ylellouch).or.(.not.hcnrad)) then + CALL GAS2_NOHCN(J, KGAS,TBAR,PBAR,U,TAU2) + else + CALL GAS2(J, KGAS,TBAR,PBAR,U,TAU2) + endif + TAUGAS=TAUGAS+TAU2 + ENDIF +C + + DTAUI_1pt(J,K)=TAUGAS+TAEROS+TNUAGE + DTAUIP_1pt(J,K)=TAUGAS+TAEROS + + TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS + TAUHID_1pt(J,K)=TAUHI_1pt(K) + + TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS + TAUGID_1pt(J,K)=TAUGI_1pt(K) + + TAUCI_1pt(K)=TAUCI_1pt(K) + TNUAGE + TAUCID_1pt(J,K)=TAUCI_1pt(K) + +C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE! + + TLIMIT=1.E-16 + + + IF (TAEROSCAT + TNUAGESCAT .GT. 0.) THEN + COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CNBAR*TNUAGESCAT ) + & /(TAEROSCAT + TNUAGESCAT) + ELSE + COSBI_1pt(J,K)=0.0 + ENDIF + + IF (TAEROSCAT .GT. 0.) THEN + COSBIP_1pt(J,K)=(CBAR*TAEROSCAT) + & /(TAEROSCAT) + ELSE + COSBIP_1pt(J,K)=0.0 + ENDIF + +*--------- + + IF (DTAUI_1pt(J,K) .GT. TLIMIT) THEN + WBARI_1pt(J,K)=(TAEROSCAT+TNUAGESCAT) /DTAUI_1pt(J,K) + ELSE + WBARI_1pt(J,K)=0.0 + DTAUI_1pt(J,K)=TLIMIT + ENDIF + + IF (DTAUIP_1pt(J,K) .GT. TLIMIT) THEN + WBARIP_1pt(J,K)=(TAEROSCAT) /DTAUIP_1pt(J,K) + ELSE + WBARIP_1pt(J,K)=0.0 + DTAUIP_1pt(J,K)=TLIMIT + ENDIF + + +c IF (IPRINT .GT. 9) +c & WRITE(6,73)J,K,TAUGAS,TAEROS,QEXT,QSCT + 73 FORMAT(2I3,1P8E10.3) + + +c------------------------------------------------------------------------ + 101 CONTINUE ! FIN BOUCLE L D'O +c------------------------------------------------------------------------ + + iopti=1 + +c************************************************************************ + 100 CONTINUE ! FIN BOUCLE ALTITUDE +c************************************************************************ + + DO 119 K=1,NSPECI + TAUI_1pt(1,K)=0.0 + TAUIP_1pt(1,K)=0.0 + DO 119 J=1,NLAYER + TAUI_1pt(J+1,K)=TAUI_1pt(J,K)+DTAUI_1pt(J,K) + TAUIP_1pt(J+1,K)=TAUIP_1pt(J,K)+DTAUIP_1pt(J,K) + 119 CONTINUE + +c IF (IPRINT .GT. 2) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE INFRARED') + +c DO 200 K=1,NSPECI ! #2 +c WRITE (6,190) +c WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K) +c & ,BWNI(K)+DWNI(K),DWNI(K) +c WRITE (6,230)REALI(K),XIMGI(K) + +c DO 195 J=1,NLAYER ! #3 +c WRITE (6,220)XNUMB(J), WBARI_1pt(J,K),COSBI_1pt(J,K) +c & , DTAUI_1pt(J,K),TAUI_1pt(J,K) +c 195 CONTINUE + +c 200 CONTINUE + +c END IF + + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU') +c 220 FORMAT(5(1X,G9.3)) +c 240 FORMAT(41X,G9.3) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_3.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_3.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optci_1pt_3.F (revision 1643) @@ -0,0 +1,461 @@ + SUBROUTINE optci_1pt3(zqaer_1pt,rcdb,xfrb,iopti,IPRINT) + use dimphy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: RGAS + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "numchimrad.h" +#include "clesphys.h" + + integer nlayer, nlevel, nspeci, nspc1i, nspecv, nspc1v + real z,press, den, temp, ch4, xn2, h2, ar, xmu, gas1, + & colden, c2h2, c2h6, hcn, radius, xnumb, + & ximgi, realv, ximgv, rcldi, xicldi, rcldv, xicldv, rcldi2, + & xicldi2, rcldv2, xicldv2 + real bwni, wnoi, dwni, wlni, + & prod,reali + + integer k, j,inq,kgas + + real tbar, pbar, bmu, coef1, effg, taeros, taeroscat, cbar, + & qext, qsct, qabs, qbar, xmono, xrule, deltaz, tnuext, + & tnuscat, cnbar, qextc, qsctc, qabsc, qbarc, taugas, pnn, + & pcc, pcn, phn, u, ig, tau2, tlimit + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,iopti +C iopti: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optci_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) + COMMON /STRAT2/ HCN(NLAYER) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI), + & DWNI(NSPECI), WLNI(NSPECI) + + COMMON /part/v,rayon,vrat,dr,dv + + DIMENSION PROD(NLEVEL) +* nrad dans microtab.h + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + real xv1(klev,nspeci),xv2(klev,nspeci) + real xv3(klev,nspeci) + REAL QF1(nrad,NSPECI),QF2(nrad,NSPECI) + REAL QF3(nrad,NSPECI),QF4(nrad,NSPECI) + REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI) + REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI) + REAL QC1(nrad,NSPECI),QC2(nrad,NSPECI) + REAL QC3(nrad,NSPECI),QC4(nrad,NSPECI) + real emu + REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI) + +c ---- nuages + REAL TNUAGE,TNUAGESCAT + REAL rcdb(nlayer),xfrb(nlayer,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4,qc1,qc2,qc3,qc4 + + +C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS +C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF. +C +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C + + DO 80 K=1,NSPECI + TAUHI_1pt(K)=0. + TAUCI_1pt(K)=0. + TAUGI_1pt(K)=0. + 80 CONTINUE + +c************************************************************************ + DO 100 J=1,NLAYER ! BOUCLE SUR L'ALTITUDE +c************************************************************************ + +C SET UP THE COEFFICIENT TO REDUCE MASS PATH TO STP ...SEE NOTES +C T0 =273.15 PO=1.01325 BAR + + TBAR=0.5*(TEMP(J)+TEMP(J+1)) + PBAR=SQRT(PRESS(J)*PRESS(J+1)) + BMU=0.5*(XMU(J+1)+XMU(J)) +c attention ici, Z en km doit etre passe en m + COEF1=RGAS*273.15**2*.5E5* (PRESS(J+1)**2 - PRESS(J)**2) + & /(1.01325**2 *EFFG(Z(J)*1000.)*TBAR*BMU) + + IF (IPRINT .GT. 9) WRITE(6,21) J,EFFG(Z(J)*1000.),TBAR,BMU,COEF1 + 21 FORMAT(' J, EFFG, TBAR, BMU, COEF1,: ',I3,1P6E10.3) + +c------------------------------------------------------------------------ + DO 101 K=1,NSPECI ! BOUCLE SUR LES L.D'O +c------------------------------------------------------------------------ + + +C #1: HAZE +C--------------------- + +C FIRST COMPUTE TAU AEROSOL + + +c +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (WNOI(K).lt.wco) THEN ! lamda > 56 um + + if (iopti.eq.0) then + +c CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), +c & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + CALL CMIE(1.E-2/WNOI(K),REALI(K),XIMGI(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + + ELSE ! 0.2 < lambda < 56 um + + + if(rayon(inq).lt.RF(inq)) THEN + + if (iopti.eq.0) then + + CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K), + & QEXT,QSCT,QABS,QBAR,WNOI(K)) + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif ! end iopti + + + TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4 + + else + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + + if (iopti.eq.0) then + +c CALL OPTFRAC(XMONO,10000./WNOI(K) +c & ,QEXT,QSCT,QABS,QBAR) + + + CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + endif ! end iopti + + TAEROS=QF1(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq) + + endif + + IF(TAEROS.LT.1.e-10) TAEROS=1.e-10 + + ENDIF + ENDDO ! FIN DE LA BOUCLE SUR nrad + + + + + if (TAEROSCAT.ne.0.) CBAR=CBAR/TAEROSCAT + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*0.85 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*1.15 + TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1(K)=TAEROS + TAEROSCATM1(K)=TAEROSCAT + DELTAZM1(K)=DELTAZ + + + IF(TAEROSCAT.le.0.) CBAR=0. + +c print*,'HERE, MCKAY AEROSOLS IR' +c TAEROS=xv1(j,k) +c TAEROSCAT=xv2(j,k) +c CBAR=xv3(j,k) + +c print*, 'HERE, CIRS AEROSOLS' +c call cirs_haze(PRESS(J),WNOI(K),TAEROS,TAEROSCAT,CBAR) + +c*********** EN TRAVAUX *************************** + +C #2: CLOUD +C------------------ +C NEXT COMPUTE TAU CLOUD +c +c Menu special : +c On utilise ici une look-up table afin de calculer +c les proprietes optique des nuages. +c Le principe est le suivant : +c La look-up table contient les proprietes optique d'une goutte +c de methane pur de 3 um. +c On approxime les proprietes optiques pour une goutte de rayon r a +c de la table. +c +c + TNUEXT=0. + TNUSCAT=0. + CNBAR=0. + IF (clouds.eq.1) THEN + + CALL getoptcld(1.E-2/WNOI(K),rcdb(nlayer+1-J), + & QEXTC,QSCTC,QABSC,QBARC) + + +c ----- On ne calcule les constante optiques que si Rgoutte > 1e-10 + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + TNUEXT =QEXTC/xnuf*SUM(zqaer_1pt(NLAYER+1-J,nrad+1:2*nrad)) + TNUSCAT=QSCTC/xnuf*SUM(zqaer_1pt(NLAYER+1-J,nrad+1:2*nrad)) + CNBAR =QBARC + ENDIF + + IF(TNUSCAT.EQ.0.) THEN + CNBAR=0. + ELSE + CNBAR=CNBAR/TNUSCAT + ENDIF + + ENDIF ! Cond CLD +c +C #3: GAZ +C------------------ + +C NOW COMPUTE TAUGAS DUE TO THE PIA TERM ONLY FOR LAMDA LT 940 + TAUGAS=0.0 + IF (WNOI(K) .LT. 940. ) THEN + CALL PIA(K,TBAR,PNN,PCC,PCN,PHN) +C HERE IS WHERE WE COULD SCALE THE PIA COEFFICEINTS TO FIT DATA +C BASED ON REGIS' NOTES. ---TGM HAS THIS ADJUST IN IT AS DEFAULT + PCN=PCN*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C***REPLACE ABOVE WITH: PCN=PCN*1.25*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) +C 1.25 FACTOR (NOT FROM DATA) SUGGESTED BY TOON et al. (1988) + TAUGAS=COEF1* + & (XN2(J)*XN2(J)*PNN + CH4(J)*CH4(J)*PCC + & + XN2(J)*CH4(J)*PCN + XN2(J)*H2(J)*PHN) + IF (J .EQ. NLAYER .AND. IPRINT .GT. 9) + & WRITE (6,22) WNOI(K),TAUGAS,XN2(J),CH4(J),H2(J), + & TBAR, PNN,PCC,PCN, PHN, + & XN2(J)*XN2(J)*PNN , CH4(J)*CH4(J)*PCC , + & XN2(J)*CH4(J)*PCN , XN2(J)*H2(J)*PHN + 22 FORMAT(1X,1P8E10.2) + ENDIF + + IF (K .GT. 28) THEN + KGAS=K-28 +C ??FLAG? HERE MUST BE WATCHED CAREFULLY + U=COLDEN(J)*6.02204E23/BMU + if((ylellouch).or.(.not.hcnrad)) then + CALL GAS2_NOHCN(J, KGAS,TBAR,PBAR,U,TAU2) + else + CALL GAS2(J, KGAS,TBAR,PBAR,U,TAU2) + endif + TAUGAS=TAUGAS+TAU2 + ENDIF +C + + DTAUI_1pt(J,K)=TAUGAS+TAEROS+TNUEXT + DTAUIP_1pt(J,K)=TAUGAS+TAEROS + + TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS + TAUHID_1pt(J,K)=TAUHI_1pt(K) + + TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS + TAUGID_1pt(J,K)=TAUGI_1pt(K) + + TAUCI_1pt(K)=TAUCI_1pt(K) + TNUEXT + TAUCID_1pt(J,K)=TAUCI_1pt(K) + +C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE! + + TLIMIT=1.E-16 + + + IF (TAEROSCAT + TNUSCAT .GT. 0.) THEN + COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT ) + & /(TAEROSCAT + TNUSCAT) + ELSE + COSBI_1pt(J,K)=0.0 + ENDIF + + IF (TAEROSCAT .GT. 0.) THEN + COSBIP_1pt(J,K)=(CBAR*TAEROSCAT) + & /(TAEROSCAT) + ELSE + COSBIP_1pt(J,K)=0.0 + ENDIF + +*--------- + + IF (DTAUI_1pt(J,K) .GT. TLIMIT) THEN + WBARI_1pt(J,K)=(TAEROSCAT+TNUSCAT) /DTAUI_1pt(J,K) + ELSE + WBARI_1pt(J,K)=0.0 + DTAUI_1pt(J,K)=TLIMIT + ENDIF + + IF (DTAUIP_1pt(J,K) .GT. TLIMIT) THEN + WBARIP_1pt(J,K)=(TAEROSCAT) /DTAUIP_1pt(J,K) + ELSE + WBARIP_1pt(J,K)=0.0 + DTAUIP_1pt(J,K)=TLIMIT + ENDIF + + +c IF (IPRINT .GT. 9) +c & WRITE(6,73)J,K,TAUGAS,TAEROS,QEXT,QSCT + 73 FORMAT(2I3,1P8E10.3) + + +c------------------------------------------------------------------------ + 101 CONTINUE ! FIN BOUCLE L D'O +c------------------------------------------------------------------------ + + iopti=1 + +c************************************************************************ + 100 CONTINUE ! FIN BOUCLE ALTITUDE +c************************************************************************ + + DO 119 K=1,NSPECI + TAUI_1pt(1,K)=0.0 + TAUIP_1pt(1,K)=0.0 + DO 119 J=1,NLAYER + TAUI_1pt(J+1,K)=TAUI_1pt(J,K)+DTAUI_1pt(J,K) + TAUIP_1pt(J+1,K)=TAUIP_1pt(J,K)+DTAUIP_1pt(J,K) + 119 CONTINUE + +c IF (IPRINT .GT. 2) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE INFRARED') + +c DO 200 K=1,NSPECI ! #2 +c WRITE (6,190) +c WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K) +c & ,BWNI(K)+DWNI(K),DWNI(K) +c WRITE (6,230)REALI(K),XIMGI(K) + +c DO 195 J=1,NLAYER ! #3 +c WRITE (6,220)XNUMB(J), WBARI_1pt(J,K),COSBI_1pt(J,K) +c & , DTAUI_1pt(J,K),TAUI_1pt(J,K) +c 195 CONTINUE + +c 200 CONTINUE + +c END IF + + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU') +c 220 FORMAT(5(1X,G9.3)) +c 240 FORMAT(41X,G9.3) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcld.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcld.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcld.F90 (revision 1643) @@ -0,0 +1,278 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! MODULE optcld : +! +! regroupe les variables communes au routines/fonctions pour l'extrapolation/interpolation +! des proprietes optiques des gouttes. +! +! Contient les routines : +! INITIALISATION - lecture de la look-up table et initialisation des variables communes. +! LOCATE - Recherche de valeur dans une table. +! INTERPOLEMOI - interpolation d'une valeur a partir d'un jeu de donnees. +! EXTRAPOLEMOI - extrapolation des valeurs en dehors de la look-up table. +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + MODULE optcld + IMPLICIT NONE + REAL,SAVE :: A_ex,A_ab,A_gg, B_ex,B_ab,B_gg + REAL,SAVE :: fmin_ex,fmin_ab,fmin_gg + REAL,SAVE :: r0cld + REAL,SAVE :: lmin,lmax + INTEGER,SAVE :: npts + REAL,ALLOCATABLE,SAVE :: tq_ex(:),tq_ab(:),tq_gg(:),tq_wln(:) + REAL,ALLOCATABLE,SAVE :: ltq_ex(:),ltq_ab(:),ltq_gg(:), & + ltq_wln(:) + REAL,SAVE :: frac_c(3),fhvi_c,fhir_c,lseuil_c +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! SUBROUTINE iniqcld : +! +! Initialisation des variables commune et lecture de la look-up table. +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE iniqcld() + IMPLICIT NONE +! ---------- LOCAL + INTEGER :: i,iun + LOGICAL :: ok + CHARACTER*100 :: tmp + iun=-1 +! rechercher une unite logique libre sur les 200 premieres. + DO i=1,200 + INQUIRE (UNIT=i, OPENED=ok) + IF (.not.ok) THEN + iun=i + exit + ENDIF + ENDDO +! Une belle condition d'arret ==> aucun unite dispo. + IF (iun.eq.-1) THEN + PRINT*,"CATASTROPHE !" + PRINT*,"Impossible de trouver une unite logique libre", & + " sur les 200 premieres." + PRINT*,"Je ne peux pas lire optcld.table." + STOP "Je m'arrete (et salement en plus)..." + ENDIF +! Lecture de la table !!! + OPEN(iun,file='optcld.table') + DO i=1,4 + READ(iun,*) tmp + ENDDO + READ(iun,*) npts +! Petite pause dans la lecture pour allouer les tableaux + ALLOCATE(tq_ex(npts)) + ALLOCATE(tq_ab(npts)) + ALLOCATE(tq_gg(npts)) + ALLOCATE(tq_wln(npts)) + ALLOCATE(ltq_ex(npts)) + ALLOCATE(ltq_ab(npts)) + ALLOCATE(ltq_gg(npts)) + ALLOCATE(ltq_wln(npts)) +! Reprise de la + READ(iun,*) tmp + READ(iun,'(ES14.7)') r0cld + READ(iun,*) tmp + READ(iun,'(2(ES14.7,2X))') lmin,lmax + DO i=1,3 + READ(iun,*) tmp + ENDDO + READ(iun,'(2(ES14.7,2X))') A_ex,B_ex + READ(iun,*) tmp + READ(iun,'(2(ES14.7,2X))') A_ab,B_ab + READ(iun,*) tmp + READ(iun,'(2(ES14.7,2X))') A_gg,B_gg + DO i=1,3 + READ(iun,*) tmp + ENDDO + READ(iun,'(ES14.7)') fmin_ex + READ(iun,*) tmp + READ(iun,'(ES14.7)') fmin_ab + READ(iun,*) tmp + READ(iun,'(ES14.7)') fmin_gg + DO i=1,3 + READ(iun,*) tmp + ENDDO + READ(iun,*) (frac_c(i),i=1,3) + DO i=1,2 + READ(iun,*) tmp + ENDDO + READ(iun,*) fhvi_c,fhir_c,lseuil_c + READ(iun,*) tmp + + DO i=1,npts + READ(iun,'(4(ES23.15,1X))') & + tq_wln(i),tq_ex(i),tq_ab(i),tq_gg(i) +! ------------ on passe tout en log pour les interpolations + ltq_wln(i) = alog(tq_wln(i)) + ltq_ex(i) = alog(tq_ex(i)) + ltq_ab(i) = alog(tq_ab(i)) + ltq_gg(i) = alog(tq_gg(i)) + ENDDO + CLOSE(iun) + + WRITE(*,*) & + "LECTURE LOOK-UP optcld.table... TERMINEE :)" + + END SUBROUTINE iniqcld + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! SUBROUTINE locate(xx,n,x,j) : +! +! Recherche de l'indice j de la valeur la plus proche par defaut de x dans le tableau xx de +! dimension n +! +! ARGUMENTS D'ENTREE : +! xx : tableau dans lequel rechercher l'indice. +! x : valeur recherchee +! n : dimension de xx +! +! ARGUMENT DE SORTIE : +! j : indice de la valeur la plus proche PAR DEFAUT de x +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE locate(xx,n,x,j) + IMPLICIT NONE +! ---------- INPUT + INTEGER,INTENT(in) :: n + REAL ,INTENT(in) :: x,xx(n) + INTEGER,INTENT(out) :: j +! ---------- LOCAL + INTEGER jl,jm,ju + jl=0 + ju=n+1 + DO WHILE (ju-jl.gt.1) + jm=(ju+jl)/2 + IF (jm.eq.0) STOP "ALERTE jm=0 !!" + IF((xx(n).ge.xx(1)).eqv.(x.ge.xx(jm))) THEN + jl=jm + ELSE + ju=jm + ENDIF + ENDDO + IF (x.eq.xx(1))THEN + j=1 + ELSE IF (x.eq.xx(n)) THEN + j=n-1 + ELSE + j=jl + ENDIF + RETURN + END SUBROUTINE locate + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! SUBROUTINE interpolemoi(ii,x,xin,yin,npts,yout,ver,loga) : +! +! Interpolation d'une valeur dans un jeu de donnees xin(npts),yin(npts). +! +! ARGUMENTS D'ENTREE : +! ii : ind dans xin de la valeur la plus proche de x par defaut (locate est ton ami) +! x : abscisse de la valeur a interpoler. +! xin,yin : jeu de valeurs pour l'interpolation. +! npts : nombre de points de xin,yin. +! ver : type d'interpolation (0 = lineaire / 1 = quadratique) +! loga : interpolation en espace log +! +! ARGUMENT DE SORTIE : +! yout : valeur interpolee en x. ! +! +! NOTES : +! - Si loga est utilisee alors xin et yin doivent alors representer les logarithmes du +! jeu de donnees. +! - Quelque soit la valeur de loga, yout est la valeur interpolee dans l'espace normal +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE interpolemoi(ii,x,xin,yin,npts,yout,ver,loga) + IMPLICIT NONE +! ---------- INPUT + INTEGER,INTENT(in) :: npts + INTEGER,INTENT(inout) :: ii,ver ! ces 2 variables sont suceptible de changer + LOGICAL,INTENT(in) :: loga + REAL ,INTENT(in) :: x,xin(npts),yin(npts) +! ---------- OUTPUT + REAL ,INTENT(out) :: yout +! ---------- LOCAL + REAL :: myx,ytmp,denom + +! ---------- on pourrait ameliorer la condition ici et tester le cas +! x plus proche de x(i+1) et utiliser dans ce cas l'interpolation +! quadratique... mais est ce vraiment nécessaire ??? +! Si on est sur les 2 premiers ou les 2 derniers points : +! ===> interpolation lineaire + IF (ii.eq.1.or.ii.eq.npts-1) ver = 0 + +! Interpolation lineaire + IF (ver.eq.0) THEN + myx = x + IF (loga) myx=alog(myx) + denom = (xin(ii+1)-xin(ii)) + ytmp=((yin(ii+1)-yin(ii))*(myx-xin(ii)))/denom+yin(ii) + IF (loga) THEN + yout=exp(ytmp) + ELSE + yout=ytmp + ENDIF + ELSE +! ------------ Recherche de l'indice le plus proche de la valeur. +! Permet de choisir si l'on interpole avec : +! i-1;i;i+1 OU i;i+1;i+2 + IF (x-xin(ii).gt.xin(ii+1)-x) ii = ii+1 + myx=x + IF (loga) myx=alog(myx) + ytmp = (myx-xin(ii))*(myx-xin(ii+1)) / & + ((xin(ii-1)-xin(ii)) * & + (xin(ii-1)-xin(ii+1))) * & + yin(ii-1) & + + & + (myx-xin(ii-1))*(myx-xin(ii+1)) / & + ((xin(ii)-xin(ii-1)) * & + (xin(ii)-xin(ii+1))) * & + yin(ii) & + + & + (myx-xin(ii-1))*(myx-xin(ii)) / & + ((xin(ii+1)-xin(ii-1)) * & + (xin(ii+1)-xin(ii))) * & + yin(ii) + IF (loga) THEN + yout=exp(ytmp) + ELSE + yout=ytmp + ENDIF + ENDIF + RETURN + END SUBROUTINE interpolemoi + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! SUBROUTINE extrapolemoi(x,A,B,yout,loga) : +! +! Extrapolation lineaire d'une valeur a partir de coeff A et B issus d'un jeu de donnees +! xin(npts), yin(npts). [ f(x) = A*x + B OU exp(A*log(x)+B) ] +! +! ARGUMENTS D'ENTREE : +! x : abscisse de la valeur a extrapoler. +! A : coeff directeur de la droite. +! B : ordonnee a l'origine de la droite. +! loga : interpolation en espace log +! +! ARGUMENT DE SORTIE : +! yout : valeur extrapolee en x. +! +! NOTES : +! - Si loga est utilisee alors A et B n'ont pas la meme signification (voir forme f(x)) +! - Quelque soit la valeur de loga, yout est la valeur extrapolee dans l'espace normal +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE extrapolemoi(x,A,B,yout,loga) + IMPLICIT NONE +! ---------- INPUT + REAL ,INTENT(in) :: x,A,B + LOGICAL,INTENT(in) :: loga +! ---------- OUTPUT + REAL ,INTENT(out) :: yout + + IF (loga) THEN + yout = exp(A*alog(x)+B) + ELSE + yout = A*x+B + ENDIF + + END SUBROUTINE extrapolemoi + + END MODULE optcld Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcv.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcv.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcv.F (revision 1643) @@ -0,0 +1,241 @@ + SUBROUTINE OPTCV(qaer,nmicro,IPRINT) + + use dimphy + use infotrac_phy, only: nqtot + use common_mod, only:rmcbar,xfbar,ncount,TauHVD,TauCVD,TauGVD + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + +c Argument: +c --------- + REAL qaer(klon,klev,nqtot) + integer nmicro +c --------- + +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV), + & ATERM(4,NSPECV),BTERM(4,NSPECV) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /TAUS/ TAUHI(ngrid,NSPECI), TAUCI(ngrid,NSPECI) + & ,TAUGI(ngrid,NSPECI), TAURV(ngrid,NSPECV) + & ,TAUHV(ngrid,NSPECV) ,TAUCV(ngrid,NSPECV) + & ,TAUGV(ngrid,NSPECV) + + COMMON /OPTICV/ DTAUV(ngrid,NLAYER,NSPECV,4) + & ,TAUV(ngrid,NLEVEL,NSPECV,4) + & ,WBARV(ngrid,NLAYER,NSPECV,4) + & ,COSBV(ngrid,NLAYER,NSPECV,4) + & ,DTAUVP(ngrid,NLAYER,NSPECV,4) + & ,TAUVP(ngrid,NLEVEL,NSPECV,4) + & ,WBARVP(ngrid,NLAYER,NSPECV,4) + & ,COSBVP(ngrid,NLAYER,NSPECV,4) + + COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) + & ,DWNV(NSPECV),WLNV(NSPECV) + + COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + + REAL xv1(klev,NSPECV) + REAL xv2(klev,NSPECV) + REAL xv3(klev,NSPECV) + + REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV) + REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV) + REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV) + REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 + + integer ioptv,iwarning ! ioptv: premier appel, une seule boucle sur les l.d'o. + integer ig_,seulmtunpt + save ioptv,iwarning,seulmtunpt + data ioptv,iwarning,seulmtunpt/0,0,0/ + + real zqaer_1pt(NLAYER,2*nrad) +#include "optcv_1pt.h" + + character*100 dummy + real dummy2,dummy3 + +C* +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE +C IT CALCULATES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C + sum=0. + PRINT*,'OPTCV' + print*,'ATTENTION, TAU UNIFORME DANS OPTCV' + +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c INITIALISATIONS UNE SEULE FOIS +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (ioptv.eq.0) then + +c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqtot=1, +c il faut quand meme qu'on lise la look-up table de dim nrad=10 +c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h) +c +c Nouvelle verif pour nuages : +c La condition ci-dessus n'est plus realisable ! +c nmicro comprend maintenant aussi des glaces +c Donc on teste juste que nmicro soit > 2*nrad (ou nrad si on ne fait pas de nuages) + if (microfi.ge.1) then + if ((clouds.eq.1).and.(nmicro.lt.2*nrad)) then + print*,"OPTCV :" + print*,"clouds = 1 MAIS nmicro < 2*nrad" + print*,"Probleme pour zqaer_1pt dans optcv." + stop + endif + if ((clouds.eq.0).and.(nmicro.lt.nrad)) then + print*,"OPTCV :" + print*,"nmicro < nrad" + print*,"Probleme pour zqaer_1pt dans optcv." + stop + endif + endif + + DO 130 K=1,NSPECV +C LETS USE THE OPTICAL CONSTANTS FOR THOLIN +c CALL THOLIN(WLNV(K),TNR,TNI) + CALL THOLIN_CVD(WLNV(K),TNR,TNI) + REALV(K)=TNR + XIMGV(K)=TNI*FHVIS +C BUT WE NOW USE THE GEOMETRIC ALBEDO FITTED RESULTS +C XIMGV(K)=FITEDT(WLNV(K)) +C XIMGV(K)=FITEDN(WLNV(K)) +C THE CLOUD IS CLEAR IN THE VISIBLE + CALL LIQCH4(WLNV(K),TNR,TNI) + RCLDV(K)=TNR + XICLDV(K)=TNI + CALL LIQC2H6(WLNV(K),TNR,TNI) + RCLDV2(K)=TNR + XICLDV2(K)=TNI + 130 CONTINUE +C +c open (unit=1,file='xsetupv') +c do j=1,nspecv +c read(1,*) a +c do i=1,klev +c read(1,*) xv1(i,j),xv2(i,j),xv3(i,j) +c enddo +c enddo +c close(1) + +c DEBUG +c print*,"wnov=",WNOV + + endif ! fin initialisations premier appel + +c******* DEBUT DES BOUCLE GRILLE ************************ +c PRINT*, 'AEROSOLS EN VISIBLE' + + DO 101 ig=1,klon !c! BOUCLE SUR GRILLE HORIZONTALE + + if (microfi.ge.1) then + do iq=1,2*nrad + if (clouds.eq.0.and.iq.gt.nrad) then + zqaer_1pt(:,iq)=0. + else + do j=1,NLAYER + zqaer_1pt(j,iq)=qaer(ig,j,iq) + enddo + endif + enddo + else + if (ig.eq.1) then +c initialisation zqaer_1pt a partir d une look-up table (uniforme en ig) +c boucle sur nrad=10 + open(10,file="qaer_eq_1d.dat") + do iq=1,15 + read(10,'(A100)') dummy + enddo + do j=NLAYER,1,-1 + read(10,*) dummy2,dummy3,(zqaer_1pt(j,iq),iq=1,nrad) + enddo + close(10) + endif + endif + +c if ((ig.eq.klon/2).or.(microfi.eq.0)) then +c print*,"Q01=",zqaer_1pt(:,1) +c print*,"Q05=",zqaer_1pt(:,5) +c print*,"Q10=",zqaer_1pt(:,10) +c stop +c endif + + iout=0 +c if ((microfi.eq.0).or.(ig.eq.klon/2)) iout=1 + if (seulmtunpt.eq.0) then + call optcv_1pt3(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:), + & ioptv,IPRINT) + ioptv = 1 + endif + +c Pas de microphysique, ni de composition variable: un seul passage +c dans optcv_1pt. + if ((microfi.eq.0).and.(ylellouch)) then + seulmtunpt = 1 + endif + + COSBV(ig,:,:,:)= MAX(MIN(COSBV_1pt(:,:,:),0.999999),1e-6) + WBARV(ig,:,:,:)= MAX(MIN(WBARV_1pt(:,:,:),0.999999),1e-6) + DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:) + TAUV(ig,:,:,:) = TAUV_1pt(:,:,:) + + COSBVP(ig,:,:,:)= MAX(MIN(COSBVP_1pt(:,:,:),0.999999),1e-6) + WBARVP(ig,:,:,:)= MAX(MIN(WBARVP_1pt(:,:,:),0.999999),1e-6) + DTAUVP(ig,:,:,:)= DTAUVP_1pt(:,:,:) + TAUVP(ig,:,:,:) = TAUVP_1pt(:,:,:) + + TAUHV(ig,:) = TAUHV_1pt(:) + TAUCV(ig,:) = TAUCV_1pt(:) + TAURV(ig,:) = TAURV_1pt(:) + TAUGV(ig,:) = TAUGV_1pt(:) + + TauHVD(ig,:,:) = TAUHVD_1pt(:,:) + TauCVD(ig,:,:) = TAUCVD_1pt(:,:) + TauGVD(ig,:,:) = TAUGVD_1pt(:,:) + +c DEBUG +c if(ig.eq.(ngrid/2+16)) then +c print*,ig,'/',KLON,':' +c print*,'TauHVD_1',TAUHVD(ig,1,:) +c print*,'TauGVD_1',TAUGVD(ig,1,:) +c print*,'TauHVD_50',TAUHVD(ig,50,:) +c print*,'TauGVD_50',TAUGVD(ig,50,:) +c stop +c endif + + 101 CONTINUE + +c FIN BOUCLE GRILLE ******* +c****************************** + + PRINT*, 'FIN OPTCV' + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.F (revision 1643) @@ -0,0 +1,490 @@ + SUBROUTINE optcv_1pt(zqaer_1pt,rcdb,xfrb,ioptv,IPRINT) + + + use dimphy +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,ioptv +C ioptv: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optcv_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV), + & ATERM(4,NSPECV),BTERM(4,NSPECV) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) + & ,DWNV(NSPECV),WLNV(NSPECV) + +* nrad dans microtab.h + COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + + REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV) + REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV) + REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV) + REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV) + REAL QC1(nrad,NSPECV),QC2(nrad,NSPECV) + REAL QC3(nrad,NSPECV),QC4(nrad,NSPECV) + +c---- NUAGES + real TNUABS,TNUSCAT + real rcdb(NLAYER) + real xfrb(NLAYER,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 + + integer ilat,jalt + common/toto/ilat,jalt + +C* +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C +C ZERO THE COLUMN OPTICAL DEPTHS OF EACH TYPE +C ??FLAG? THE OPTICAL DEPTH OF THE TOP OF THE MODEL +C MAY NOT BE ZERO. + +c******* DEBUT DES BOUCLES ************************ + DO 100 K=1,NSPECV !b! BOUCLE SUR LAMBDA + + TAURV_1pt(K)=0. + TAUHV_1pt(K)=0. ! INTEGRATED TAU.......INITIALIZATION. + TAUCV_1pt(K)=0. ! Rayleigh, Haze, Cloud, Gas + TAUGV_1pt(K)=0. ! sca, abs, abs , abs + + DO 100 J=1,NLAYER !a! BOUCLE SUR L"ALTITUDE + jalt=j +C #1: HAZE +c--------------------------- + +c CALL THE MIE CODE TO GIVE THE AEROSOL PROPERTIES +c USE XFRAC FOR FRACTAL AEROSOLS PROPERTIES AT LAMBDA < 2. um + + + + +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + +c print*,"rayon=",rayon +c print*,"RF=",RF + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (rayon(inq).lt.RF(inq)) THEN ! aerosols spheriques + + + if(ioptv.eq.0.and.J.eq.1) then +c CALL XMIE(rayon(inq)*1.e6,REALV(K),XIMGV(K), +c & QEXT,QSCT,QABS,QBAR,WNOV(K)) + + CALL CMIE(1.E-2/WNOV(K),REALV(K),XIMGV(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + +c print*,'inq=',inq,' QM1=',QM1(inq,K),' QEXT=',QEXT + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif + + TAEROS=QM1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4 + + ELSE ! aerosols fractals + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + if(ioptv.eq.0.and.J.eq.1) then + +c CALL OPTFRAC(XMONO,10000./WNOV(K) +c & ,QEXT,QSCT,QABS,QBAR) + + CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + +c print*,'inq=',inq,' QF1=',QF1(inq,K),' QEXT=',QEXT,' XRULE=',XRULE + + endif + + TAEROS=QF1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq) + + ENDIF + + + ENDDO ! nrad + + + CBAR=CBAR/TAEROSCAT + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*0.85 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*1.15 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1=TAEROS + TAEROSCATM1=TAEROSCAT + DELTAZM1=DELTAZ + + + IF (TAEROSCAT.le.0.) CBAR=0. + +c if (IPRINT.eq.1) then +c if (k.eq.NSPECV/2) then +c write(*,1699) '@VI',K,J,TAEROS,TAEROSCAT,CBAR +c write(*,1699) '@ ',K,J,QF1(1,K),QF2(1,K),zqaer_1pt(NLAYER+1-J,1) +c write(*,1699) '@ ',K,J,QF1(3,K),QF2(3,K),zqaer_1pt(NLAYER+1-J,3) +c write(*,1699) '@ ',K,J,QF1(5,K),QF2(5,K),zqaer_1pt(NLAYER+1-J,5) +c write(*,1699) '@ ',K,J,QF1(7,K),QF2(7,K),zqaer_1pt(NLAYER+1-J,7) +c write(*,1699) '@ ',K,J,QF1(9,K),QF2(9,K),zqaer_1pt(NLAYER+1-J,9) +c print* +c endif +c endif + +1699 FORMAT(a3,2I3,3(ES15.7,1X)) + +c*********** EN TRAVAUX *************************** + +C #2: RAYLEIGH +c------------------------------- + +C RAYLEIGH SCATTERING STRAIGHT FROM HANSEN AND TRAVIS...SEE NOTES +C RATIOED BY THE LAYER COLUMN NUMBER TO THE TOTAL +C COLUMN NUMBER ON EARTH. CM-2 +C THIS IS THE SCATTERING BY THE ATMOSPHERE + + TAURAY=(COLDEN(J)*28.9/(XMU(J)*1013.25))* + &(.008569/WLNV(K)**4)*(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4) + +c PRINT*,WLNV(K) +c COLX=0. +c COLP=0. +c COLT=0. +c DO IU=1,NLAYER +c COLP=COLDEN(IU)*1.e+1*1.35+COLP +c TAURAY=(COLDEN(IU)*28.9/(XMU(IU)*1013.25))* +c & (.008569/WLNV(K)**4)*(1.+.0113/WLNV(K)**2 +c & +.00013/WLNV(K)**4) +c COLT=COLT+TAURAY +c COLX=COLDEN(IU)*1.e+1/(1.E5*28./22.4E3)*1.e-1*0.0933e-1+COLX +c | +c | +c g/cm2->kg/m2 | m2/kg +c Print*,IU, tauray, +c & COLDEN(IU)*1.e+1/(1.E5*28./22.4E3)*1.e-1*0.543e-1 +c ENDDO +c PRINT*,COLP,' PRESSURE AT GROUND;' +c PRINT*,COLX,' TAU_GAS AT GROUND;' +c print*,colt,colx,' COLT, COLX' +c STOP + +c DZ=Z(J)-Z(J+1) +c PRINT*, Z(J),WLNV(K), +c &(28.9/(XMU(J)*1013.25))*(.008569/WLNV(K)**4)* +c &(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4) +c & ,COLDEN(J)/DZ/100000., +c &(28.9/(XMU(J)*1013.25))*(.008569/WLNV(K)**4)* +c &(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4) +c & *COLDEN(J)/DZ/100000. + + + +C #3: CLOUD +c---------------------------- + +C NEXT COMPUTE TAU CLOUD + + IF (clouds.eq.0) THEN + CNBAR=0. + TNUSCAT=0. + TNUABS=0. + TBNUABS=0. + ELSE + CNBAR=0. + TNUSCAT=0. + TNUABS=0. + TBNUABS=0. + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + + do inq=1,nrad + QC1(INQ,k)=0. + QC2(INQ,k)=0. + QC3(INQ,k)=0. + QC4(INQ,k)=0. + enddo + + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + +** OPTICAL CONSTANT : MIXING RULES + + XNR=xfrb(nlayer+1-J,1)*REALV(K) ! + & +xfrb(nlayer+1-J,2)*RCLDV(K) ! + & +xfrb(nlayer+1-J,3)*RCLDV2(K) ! + & +xfrb(nlayer+1-J,4)*RCLDV2(K) ! + + XNI=xfrb(nlayer+1-J,1)*XIMGV(K) + & +xfrb(nlayer+1-J,2)*XICLDV(K) + & +xfrb(nlayer+1-J,3)*XICLDV2(K) + & +xfrb(nlayer+1-J,4)*XICLDV2(K) + +** OPTICAL CONSTANT : LIQUID DROP = THOLIN + IF(xfrb(nlayer+1-J,1).ge.0.01) THEN + XNI=XIMGV(K) + XNR=REALV(K) + ENDIF + + IF (XNI.gt.1.e-10 .and. XNR.gt.1.00) THEN + CALL CMIE(1.E-2/WNOV(K),XNR,XNI, + & rcdb(nlayer+1-J), + & QEXTC,QSCTC,QABSC,CBARC) + ELSE + PRINT*,' WARNING XNR/XNI in optcv: ',XNR,XNI + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + STOP + ENDIF + ELSE + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + ENDIF + + DO inq=1,nrad + + QC1(INQ,k)=QEXTC/xnuf + QC2(INQ,k)=QSCTC/xnuf + QC3(INQ,k)=QABSC/xnuf + QC4(INQ,k)=CBARC + + TNUABS=QC1(inq,K)*zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4 + & +TNUABS + + TNUSCAT=QC2(inq,K)*zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4 + & +TNUSCAT + + CNBAR=QC4(inq,K)*QC2(inq,K)* + & zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4 + CNBAR + + ENDDO + + IF(TNUSCAT.EQ.0) CNBAR=0. + IF(TNUSCAT.NE.0.) CNBAR=CNBAR/TNUSCAT + + + ENDIF ! Cond. CLD + + TAURV_1pt(K)=TAURV_1pt(K)+TAURAY + TAUGVD_1pt(J,K)=TAURV_1pt(K) + + TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS ! INTEGRATED Quant. + TAUHVD_1pt(J,K)=TAUHV_1pt(K) + + TAUCV_1pt(K)=TAUCV_1pt(K)+TNUABS + TAUCVD_1pt(J,K)=TAUCV_1pt(K) + + +C #4: TAUGAS +C---------------------------- + +C LOOP OVER THE NTERMS +C THIS IS THE ABSORPTION BY THE ATMOSPHERE (METHANE) + + + DO 909 NT=1,NTERM(K) + TAUGAS=COLDEN(J)*GAS1(J)*BTERM(NT,K)* + & ( (PRESS(J+1) + PRESS(J))*.5 )**PEXPON(K) + + +* COSBV ET COSBVP +*----------------- + + IF(TAEROSCAT+TNUSCAT+TAURAY .ne. 0.) THEN + COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT) + & /(TAEROSCAT+TNUSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBV_1pt(J,K,NT)=0. + ENDIF + + IF(TAEROSCAT+TAURAY .ne. 0.) THEN + COSBVP_1pt(J,K,NT)=(CBAR*TAEROSCAT) + & /(TAEROSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBVP_1pt(J,K,NT)=0. + ENDIF + +* DTAUV ET DTAUVP +*----------------- + + DTAUV_1pt(J,K,NT) =TAUGAS+TAEROS+TAURAY+TNUABS !TAU_ABS_METH + DTAUVP_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY !TAU_ABS_METH + + TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K) !INTEG. + +* WBARV ET WBARVP +*----------------- + + IF(TAUGAS+TAEROS+TAURAY+TNUABS .ne. 0.) THEN + WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + TNUSCAT) + & /(TAUGAS+TAEROS+TAURAY+TNUABS) + ELSE + WBARV_1pt(J,K,NT)=0. + ENDIF + + IF(TAUGAS+TAEROS+TAURAY .ne. 0.) THEN + WBARVP_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 ) + & /(TAUGAS+TAEROS+TAURAY) + ELSE + WBARVP_1pt(J,K,NT)=0. + ENDIF + + 909 CONTINUE + TAUGVD_1pt(J,K)=TAUGVD_1pt(J,K)+TAUGV_1pt(K) + 100 CONTINUE + ioptv=1 + +c HERE END OF THE LOOPS ******* +c****************************** + +C TOTAL EXTINCTION OPTICAL DEPTHS + DO 119 K=1,NSPECV +C LOOP OVER NTERMS + DO 119 NT=1,NTERM(K) + TAUV_1pt(1,K,NT)=0.0 + TAUVP_1pt(1,K,NT)=0.0 + DO 119 J=1,NLAYER + TAUV_1pt(J+1,K,NT)=TAUV_1pt(J,K,NT)+DTAUV_1pt(J,K,NT) + TAUVP_1pt(J+1,K,NT)=TAUVP_1pt(J,K,NT)+DTAUVP_1pt(J,K,NT) + 119 CONTINUE + +c print*,'SETUP' +c do i=1,NSPECV +c print*,WLNV(i) +c do j=1,NLAYER+1 +c print*,Z(j),TAUV(1,j,i,1),WBARV(1,j,i,1),COSBV(1,j,i,1) +c enddo +c enddo +c +c IF (IPRINT .GT. 1) THEN +c NT=1 +c IF (2 .GT. 1) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE VISIBLE (@EQUATOR) ') +c WRITE(6,*) 'latitude:',ig +c DO 200 K=1,NSPECV +c WRITE (6,190) +c WRITE (6,210)K,WLNV(K),WNOV(K),BWNV(K) +c & ,BWNV(K)+DWNV(K),DWNV(K) +c WRITE (6,230)REALV(K),XIMGV(K) +c DO 195 J=1,NLAYER,NLAYER +C RECALCULATE FOR PRINT OUT ONLY, ONLY FIRST NTERM AT ig=12 (EQUATOR) +c WRITE (6,220)XNUMB(J), WBARV_1pt(J,K,NT),COSBV_1pt(J,K,NT) +c & ,DTAUV_1pt(J,K,NT),TAUV_1pt(J,K,NT) +c 195 CONTINUE +c WRITE (6,240) TAUV_1pt(NLEVEL,K,NT) +c 200 CONTINUE +c END IF + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU' +c & ,9X,'RAY GAS AEROSOL') +c 220 FORMAT(8(1X,F9.3)) +c 240 FORMAT(41X,F9.3) + + if (IPRINT.eq.1) stop + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt.h (revision 1643) @@ -0,0 +1,48 @@ +!---------------------------------------------- +! fichier optcv_1p.h +! +! regroupe les sorties du fichier optcv_1pt +! les nuages oblige a quasiment doubler +! le nombre de variables c'est juste pour +! la lisibilite. +!---------------------------------------------- + +! ----DIAGNOSTIQUES + real TAUHVD_1pt(NLAYER,NSPECV) + real TAUCVD_1pt(NLAYER,NSPECV) + real TAUGVD_1pt(NLAYER,NSPECV) +! ----OPACITES TOTALES + real TAUHV_1pt(NSPECV) + real TAUCV_1pt(NSPECV) + real TAURV_1pt(NSPECV) + real TAUGV_1pt(NSPECV) +! ----COLONNE NUAGEUSE + real TAUV_1pt(NLEVEL,NSPECV,4) + real DTAUV_1pt(NLAYER,NSPECV,4) + real WBARV_1pt(NLAYER,NSPECV,4) + real COSBV_1pt(NLAYER,NSPECV,4) +! ----COLONNE "CLAIRE" + real TAUVP_1pt(NLEVEL,NSPECV,4) + real DTAUVP_1pt(NLAYER,NSPECV,4) + real WBARVP_1pt(NLAYER,NSPECV,4) + real COSBVP_1pt(NLAYER,NSPECV,4) + + common/optv_1pt/ & + & TAUHVD_1pt & + & ,TAUCVD_1pt & + & ,TAUGVD_1pt & +! ----OPACITES TOTALES + & ,TAUHV_1pt & + & ,TAUCV_1pt & + & ,TAUGV_1pt & +! ----COLONNE NUAGEUSE + & ,DTAUV_1pt & + & ,TAUV_1pt & + & ,WBARV_1pt & + & ,COSBV_1pt & +! ----COLONNE "CLAIRE" + & ,DTAUVP_1pt & + & ,TAUVP_1pt & + & ,WBARVP_1pt & + & ,COSBVP_1pt + Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_2.F (revision 1643) @@ -0,0 +1,430 @@ + SUBROUTINE optcv_1pt2(zqaer_1pt,rcdb,xfrb,ioptv,IPRINT) + + use dimphy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,ioptv +C ioptv: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optcv_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV), + & ATERM(4,NSPECV),BTERM(4,NSPECV) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) + & ,DWNV(NSPECV),WLNV(NSPECV) + +* nrad dans microtab.h + COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + + REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV) + REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV) + REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV) + REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV) + REAL QC1(nrad,NSPECV),QC2(nrad,NSPECV) + REAL QC3(nrad,NSPECV),QC4(nrad,NSPECV) + +c---- NUAGES + real TNUABS,TNUSCAT + real rcdb(NLAYER), xfrb(NLAYER,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4,qc1,qc2,qc3,qc4 + + +C* +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C +C ZERO THE COLUMN OPTICAL DEPTHS OF EACH TYPE +C ??FLAG? THE OPTICAL DEPTH OF THE TOP OF THE MODEL +C MAY NOT BE ZERO. + +c******* DEBUT DES BOUCLES ************************ + DO 100 K=1,NSPECV !b! BOUCLE SUR LAMBDA + + TAURV_1pt(K)=0. + TAUHV_1pt(K)=0. ! INTEGRATED TAU.......INITIALIZATION. + TAUCV_1pt(K)=0. ! Rayleigh, Haze, Cloud, Gas + TAUGV_1pt(K)=0. ! sca, abs, abs , abs + + DO 100 J=1,NLAYER !a! BOUCLE SUR L"ALTITUDE + +C #1: HAZE +c--------------------------- + +c CALL THE MIE CODE TO GIVE THE AEROSOL PROPERTIES +c USE XFRAC FOR FRACTAL AEROSOLS PROPERTIES AT LAMBDA < 2. um + + + + +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + +c print*,"rayon=",rayon +c print*,"RF=",RF + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (rayon(inq).lt.RF(inq)) THEN ! aerosols spheriques + + + if(ioptv.eq.0.and.J.eq.1) then +c CALL XMIE(rayon(inq)*1.e6,REALV(K),XIMGV(K), +c & QEXT,QSCT,QABS,QBAR,WNOV(K)) + + CALL CMIE(1.E-2/WNOV(K),REALV(K),XIMGV(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + +c print*,'inq=',inq,' QM1=',QM1(inq,K),' QEXT=',QEXT + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif + + TAEROS=QM1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4 + + ELSE ! aerosols fractals + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + if(ioptv.eq.0.and.J.eq.1) then + + CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + +c print*,'inq=',inq,' QF1=',QF1(inq,K),' QEXT=',QEXT,' XRULE=',XRULE + + endif + + TAEROS=QF1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq) + + ENDIF + + ENDDO ! nrad + + IF(TAEROSCAT.le.0.) then + CBAR=0. + ELSE + CBAR=CBAR/TAEROSCAT + ENDIF + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*0.85 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*1.15 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1=TAEROS + TAEROSCATM1=TAEROSCAT + DELTAZM1=DELTAZ + + + IF (TAEROSCAT.le.0.) CBAR=0. + +1699 FORMAT(a3,2I3,3(ES15.7,1X)) + +c*********** EN TRAVAUX *************************** + +C #2: RAYLEIGH +c------------------------------- + +C RAYLEIGH SCATTERING STRAIGHT FROM HANSEN AND TRAVIS...SEE NOTES +C RATIOED BY THE LAYER COLUMN NUMBER TO THE TOTAL +C COLUMN NUMBER ON EARTH. CM-2 +C THIS IS THE SCATTERING BY THE ATMOSPHERE + + TAURAY=(COLDEN(J)*28.9/(XMU(J)*1013.25))* + &(.008569/WLNV(K)**4)*(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4) + + +C #3: CLOUD +c---------------------------- +C NEXT COMPUTE TAU CLOUD +c +c Menu special : +c Afin d'eviter la surcharge de calcul on ne calcule les +c propriétes optiques des nuages qu'une seule fois +c avec un rayon de particule effectif de 3um et une composition +c de goutte : 90% CH4 / 10% NOYAUX +c Puis on ajute les section efficace par la surface reelle de +c la goutte. +c +c ---> A TESTER !!!! +c + IF (clouds.eq.0) THEN + CNBAR=0. + TNUSCAT=0. + TNUABS=0. + ELSE + IF (ioptv.eq.0.and.j.eq.1) THEN !--> au premier appel + QEXTC=0. + QSCTC=0. + QABSC=0. + CBARC=0. + DO inq=1,nrad !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS + QC1(inq,K)=0. + QC2(inq,K)=0. + QC3(inq,K)=0. + QC4(inq,K)=0. + ENDDO +** OPTICAL CONSTANT : MIXING RULES +** Fraction volumique fixe : +** 10% noyaux. +** 90% methane. + XNR = 0.5 * REALI(K) + & + 0.5 * RCLDI(K) + XNI = 0.5 * XIMGI(K) + & + 0.5 * XICLDI(K) +** +** Efficacite : particule de 3um de rayon + CALL CMIE(1.E-2/WNOV(K),XNR,XNI,3.e-6, + & QEXTC,QSCTC,QABSC,CBARC) + + DO inq=1,nrad + QC1(inq,K)=QEXTC/xnuf + QC2(inq,K)=QSCTC/xnuf + QC3(inq,K)=QABSC/xnuf + QC4(inq,K)=CBARC + ENDDO + ENDIF ! ioptv = 0 + TNUABS=0. + TNUSCAT=0. + CNBAR=0. + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + DO inq=1,nrad + TNUABS=QC1(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4* + & zqaer_1pt(NLAYER+1-J,inq+nrad) + + & TNUABS + TNUSCAT=QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4* + & zqaer_1pt(NLAYER+1-J,inq+nrad) + + & TNUSCAT + CNBAR=QC4(inq,K)*QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.* + & 1.e-4*zqaer_1pt(NLAYER+1-J,inq+nrad) + + & CNBAR + ENDDO + ENDIF + + IF(TNUSCAT.EQ.0.) THEN + CNBAR=0. + ELSE + CNBAR=CNBAR/TNUSCAT + ENDIF + ENDIF ! Cond. CLD + + TAUCV_1pt(K)=TAUCV_1pt(K)+TNUABS + TAUCVD_1pt(J,K)=TAUCV_1pt(K) + + TAURV_1pt(K)=TAURV_1pt(K)+TAURAY + TAUGVD_1pt(J,K)=TAURV_1pt(K) + + TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS ! INTEGRATED Quant. + TAUHVD_1pt(J,K)=TAUHV_1pt(K) + + + +C #4: TAUGAS +C---------------------------- + +C LOOP OVER THE NTERMS +C THIS IS THE ABSORPTION BY THE ATMOSPHERE (METHANE) + + + DO 909 NT=1,NTERM(K) + TAUGAS=COLDEN(J)*GAS1(J)*BTERM(NT,K)* + & ( (PRESS(J+1) + PRESS(J))*.5 )**PEXPON(K) + + +* COSBV ET COSBVP +*----------------- + + IF(TAEROSCAT+TNUSCAT+TAURAY .ne. 0.) THEN + COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT) + & /(TAEROSCAT+TNUSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBV_1pt(J,K,NT)=0. + ENDIF + + IF(TAEROSCAT+TAURAY .ne. 0.) THEN + COSBVP_1pt(J,K,NT)=(CBAR*TAEROSCAT) + & /(TAEROSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBVP_1pt(J,K,NT)=0. + ENDIF + +* DTAUV ET DTAUVP +*----------------- + + DTAUV_1pt(J,K,NT) =TAUGAS+TAEROS+TAURAY+TNUABS !TAU_ABS_METH + DTAUVP_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY !TAU_ABS_METH + + TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K) !INTEG. + +* WBARV ET WBARVP +*----------------- + + IF(TAUGAS+TAEROS+TAURAY+TNUABS .ne. 0.) THEN + WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + TNUSCAT) + & /(TAUGAS+TAEROS+TAURAY+TNUABS) + ELSE + WBARV_1pt(J,K,NT)=0. + ENDIF + + IF(TAUGAS+TAEROS+TAURAY .ne. 0.) THEN + WBARVP_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 ) + & /(TAUGAS+TAEROS+TAURAY) + ELSE + WBARVP_1pt(J,K,NT)=0. + ENDIF + + 909 CONTINUE + + TAUGVD_1pt(J,K)=TAUGVD_1pt(J,K)+TAUGV_1pt(K) + + 100 CONTINUE + + ioptv=1 + +c HERE END OF THE LOOPS ******* +c****************************** + +C TOTAL EXTINCTION OPTICAL DEPTHS + DO 119 K=1,NSPECV +C LOOP OVER NTERMS + DO 119 NT=1,NTERM(K) + TAUV_1pt(1,K,NT)=0.0 + TAUVP_1pt(1,K,NT)=0.0 + DO 119 J=1,NLAYER + TAUV_1pt(J+1,K,NT)=TAUV_1pt(J,K,NT)+DTAUV_1pt(J,K,NT) + TAUVP_1pt(J+1,K,NT)=TAUVP_1pt(J,K,NT)+DTAUVP_1pt(J,K,NT) + 119 CONTINUE + + +c print*,'SETUP' +c do i=1,NSPECV +c print*,WLNV(i) +c do j=1,NLAYER+1 +c print*,Z(j),TAUV(1,j,i,1),WBARV(1,j,i,1),COSBV(1,j,i,1) +c enddo +c enddo +c +c IF (IPRINT .GT. 1) THEN +c NT=1 +c IF (2 .GT. 1) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE VISIBLE (@EQUATOR) ') +c WRITE(6,*) 'latitude:',ig +c DO 200 K=1,NSPECV +c WRITE (6,190) +c WRITE (6,210)K,WLNV(K),WNOV(K),BWNV(K) +c & ,BWNV(K)+DWNV(K),DWNV(K) +c WRITE (6,230)REALV(K),XIMGV(K) +c DO 195 J=1,NLAYER,NLAYER +C RECALCULATE FOR PRINT OUT ONLY, ONLY FIRST NTERM AT ig=12 (EQUATOR) +c WRITE (6,220)XNUMB(J), WBARV_1pt(J,K,NT),COSBV_1pt(J,K,NT) +c & ,DTAUV_1pt(J,K,NT),TAUV_1pt(J,K,NT) +c 195 CONTINUE +c WRITE (6,240) TAUV_1pt(NLEVEL,K,NT) +c 200 CONTINUE +c END IF + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU' +c & ,9X,'RAY GAS AEROSOL') +c 220 FORMAT(8(1X,F9.3)) +c 240 FORMAT(41X,F9.3) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_3.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_3.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optcv_1pt_3.F (revision 1643) @@ -0,0 +1,404 @@ + SUBROUTINE optcv_1pt3(zqaer_1pt,rcdb,xfrb,ioptv,IPRINT) + + use dimphy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + integer nlayer, nlevel, nspeci, nspc1i, nspecv, nspc1v,nterm + real z,press, den, temp, ch4, xn2, h2, ar, xmu, gas1, + & colden, c2h2, c2h6, hcn, radius, xnumb, reali, + & ximgi, realv, ximgv, rcldi, xicldi, rcldv, xicldv, rcldi2, + & xicldi2, rcldv2, xicldv2 + real bwni, wnoi, dwni, wlni,prod + + integer k, j,inq,nt + + real tbar, pbar, bmu, coef1, effg, taeros, taeroscat, cbar, + & qext, qsct, qabs, qbar, xmono, xrule, deltaz, + & cnbar, qextc, qsctc, qabsc, qbarc, taugas, pnn, + & pcc, pcn, phn, kgas, u, ig, tau2, tlimit, + & solarf, pexpon, aterm, bterm, bwnv, wnov, dwnv, + & wlnv, v, rayon, vrat, dr, dv, taerosm1, deltazm1, + & taeroscatm1, tauray + + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + +c Arguments: +c --------- + integer IPRINT,ioptv +C ioptv: premier appel, on ne calcule qu'une fois les QM et QF +* nrad dans microtab.h + real zqaer_1pt(NLAYER,2*nrad) +#include "optcv_1pt.h" +c --------- + + COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + + COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + + COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV), + & ATERM(4,NSPECV),BTERM(4,NSPECV) + + COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) + & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) + + COMMON /CLOUD/ + & RCLDI(NSPECI), XICLDI(NSPECI) + & , RCLDV(NSPECV), XICLDV(NSPECV) + & , RCLDI2(NSPECI), XICLDI2(NSPECI) + & , RCLDV2(NSPECV), XICLDV2(NSPECV) + + COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) + & ,DWNV(NSPECV),WLNV(NSPECV) + +* nrad dans microtab.h + COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + + REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV) + REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV) + REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV) + REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV) + +c---- NUAGES + real TNUEXT,TNUSCAT + real rcdb(NLAYER), xfrb(NLAYER,4) + + save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 + + +C* +C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE +C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS +C LAYER: WBAR, DTAU, COSBAR +C LEVEL: TAU +C +C ZERO THE COLUMN OPTICAL DEPTHS OF EACH TYPE +C ??FLAG? THE OPTICAL DEPTH OF THE TOP OF THE MODEL +C MAY NOT BE ZERO. + +c******* DEBUT DES BOUCLES ************************ + DO 100 K=1,NSPECV !b! BOUCLE SUR LAMBDA + + TAURV_1pt(K)=0. + TAUHV_1pt(K)=0. ! INTEGRATED TAU.......INITIALIZATION. + TAUCV_1pt(K)=0. ! Rayleigh, Haze, Cloud, Gas + TAUGV_1pt(K)=0. ! sca, abs, abs , abs + + DO 100 J=1,NLAYER !a! BOUCLE SUR L"ALTITUDE + +C #1: HAZE +c--------------------------- + +c CALL THE MIE CODE TO GIVE THE AEROSOL PROPERTIES +c USE XFRAC FOR FRACTAL AEROSOLS PROPERTIES AT LAMBDA < 2. um + + + + +c /\ +c / \ +c / \ +c / _O \ +c / |/ \ +c / / \ \ +c / |\ \/\ \ +c / || / \ \ +c ---------------- +c | WARNING | +c | SLOW DOWN | +c ---------------- + + + + +c*********** EN TRAVAUX *************************** + + TAEROS=0. + TAEROSCAT=0. + CBAR=0. + +c print*,"rayon=",rayon +c print*,"RF=",RF + + DO inq=1,nrad !BOUCLE SUR LES TAILLE D"AEROSOLS + + + IF (rayon(inq).lt.RF(inq)) THEN ! aerosols spheriques + + + if(ioptv.eq.0.and.J.eq.1) then +c CALL XMIE(rayon(inq)*1.e6,REALV(K),XIMGV(K), +c & QEXT,QSCT,QABS,QBAR,WNOV(K)) + + CALL CMIE(1.E-2/WNOV(K),REALV(K),XIMGV(K),rayon(inq), + & QEXT,QSCT,QABS,QBAR) + +c print*,'inq=',inq,' QM1=',QM1(inq,K),' QEXT=',QEXT + + QM1(inq,K)=QEXT + QM2(inq,K)=QSCT + QM3(inq,K)=QABS + QM4(inq,K)=QBAR + endif + + TAEROS=QM1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROS + TAEROSCAT=QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROSCAT + CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4 + + ELSE ! aerosols fractals + + XMONO=(rayon(inq)/RF(inq))**3. + XRULE=1. + + if(XMONO.gt.16384./1.5) then + XRULE=(XMONO/16384.) + XMONO=16384. + endif + + if(ioptv.eq.0.and.J.eq.1) then + +c CALL OPTFRAC(XMONO,10000./WNOV(K) +c & ,QEXT,QSCT,QABS,QBAR) + + CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2. + & ,XMONO,QSCT,QEXT,QABS,QBAR) + + + QF1(inq,K)=QEXT*XRULE + QF2(inq,K)=QSCT*XRULE + QF3(inq,K)=QABS*XRULE + QF4(inq,K)=QBAR + +c print*,'inq=',inq,' QF1=',QF1(inq,K),' QEXT=',QEXT,' XRULE=',XRULE + + endif + + TAEROS=QF1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROS + TAEROSCAT=QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROSCAT + CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq) + + ENDIF + + ENDDO ! nrad + + + if (TAEROSCAT.ne.0.) CBAR=CBAR/TAEROSCAT + + DELTAZ=Z(J)-Z(J+1) + +c -------------------------------------------------------------------- +c profil brume Pascal: fit T (sauf tropopause) et albedo +c ------------------- + if( cutoff.eq.1) then + IF(PRESS(J).gt.9.e-3) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*0.85 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*0.85 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=TAEROSM1*DELTAZ/DELTAZM1*1.15 + TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*1.15 +c TAEROS=0. +c TAEROSCAT=0. + ENDIF + endif !cutoff=1 + +c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... +c ----------------------- + if( cutoff.eq.2) then + IF(PRESS(J).gt.1.e-1) THEN + TAEROS=0. + TAEROSCAT=0. + ENDIF + endif !cutoff=2 +c -------------------------------------------------------------------- + + TAEROSM1=TAEROS + TAEROSCATM1=TAEROSCAT + DELTAZM1=DELTAZ + + + IF (TAEROSCAT.le.0.) CBAR=0. + +c print*, 'HERE, CIRS AEROSOLS' +c call cirs_haze(PRESS(J),WNOV(K),TAEROS,TAEROSCAT,CBAR) + +1699 FORMAT(a3,2I3,3(ES15.7,1X)) + +c*********** EN TRAVAUX *************************** + +C #2: RAYLEIGH +c------------------------------- + +C RAYLEIGH SCATTERING STRAIGHT FROM HANSEN AND TRAVIS...SEE NOTES +C RATIOED BY THE LAYER COLUMN NUMBER TO THE TOTAL +C COLUMN NUMBER ON EARTH. CM-2 +C THIS IS THE SCATTERING BY THE ATMOSPHERE + + TAURAY=(COLDEN(J)*28.9/(XMU(J)*1013.25))* + &(.008569/WLNV(K)**4)*(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4) + + +C #3: CLOUD +c---------------------------- +C NEXT COMPUTE TAU CLOUD +c +c Menu special : +c On utilise ici une look-up table afin de calculer +c les proprietes optique des nuages. +c Le principe est le suivant : +c La look-up table contient les proprietes optique d'une goutte +c de methane pur de 3 um. +c On approxime les proprietes optiques pour une goutte de rayon r a +c de la table. +c + TNUEXT=0. + TNUSCAT=0. + CNBAR=0. + IF (clouds.eq.1) THEN + + CALL getoptcld(1.E-2/WNOV(K),rcdb(nlayer+1-J), + & QEXTC,QSCTC,QABSC,QBARC) + TNUEXT=0. + TNUSCAT=0. + CNBAR=0. + IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN + TNUEXT =QEXTC/xnuf*SUM(zqaer_1pt(NLAYER+1-J,nrad+1:2*nrad)) + TNUSCAT=QSCTC/xnuf*SUM(zqaer_1pt(NLAYER+1-J,nrad+1:2*nrad)) + CNBAR =QBARC + ENDIF + IF(TNUSCAT.GE.0.8*TNUEXT) TNUSCAT=0.8*TNUEXT + ENDIF ! Cond. CLD + + TAUCV_1pt(K)=TAUCV_1pt(K)+TNUEXT + TAUCVD_1pt(J,K)=TAUCV_1pt(K) + + TAURV_1pt(K)=TAURV_1pt(K)+TAURAY + TAUGVD_1pt(J,K)=TAURV_1pt(K) + + TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS ! INTEGRATED Quant. + TAUHVD_1pt(J,K)=TAUHV_1pt(K) + + + +C #4: TAUGAS +C---------------------------- + +C LOOP OVER THE NTERMS +C THIS IS THE ABSORPTION BY THE ATMOSPHERE (METHANE) + + + DO 909 NT=1,NTERM(K) + TAUGAS=COLDEN(J)*GAS1(J)*BTERM(NT,K)* + & ( (PRESS(J+1) + PRESS(J))*.5 )**PEXPON(K) + + +* COSBV ET COSBVP +*----------------- + + IF(TAEROSCAT+TNUSCAT+TAURAY .ne. 0.) THEN + COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT) + & /(TAEROSCAT+TNUSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBV_1pt(J,K,NT)=0. + ENDIF + + IF(TAEROSCAT+TAURAY .ne. 0.) THEN + COSBVP_1pt(J,K,NT)=(CBAR*TAEROSCAT) + & /(TAEROSCAT+TAURAY) !CBAR_RAY=0. + ELSE + COSBVP_1pt(J,K,NT)=0. + ENDIF + +* DTAUV ET DTAUVP +*----------------- + + DTAUV_1pt(J,K,NT) =TAUGAS+TAEROS+TAURAY+TNUEXT !TAU_ABS_METH + DTAUVP_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY !TAU_ABS_METH + + TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K) !INTEG. + +* WBARV ET WBARVP +*----------------- + + IF(TAUGAS+TAEROS+TAURAY+TNUEXT .ne. 0.) THEN + WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + TNUSCAT) + & /(TAUGAS+TAEROS+TAURAY+TNUEXT) + ELSE + WBARV_1pt(J,K,NT)=0. + ENDIF + + IF(TAUGAS+TAEROS+TAURAY .ne. 0.) THEN + WBARVP_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 ) + & /(TAUGAS+TAEROS+TAURAY) + ELSE + WBARVP_1pt(J,K,NT)=0. + ENDIF + + 909 CONTINUE + + TAUGVD_1pt(J,K)=TAUGVD_1pt(J,K)+TAUGV_1pt(K) + + 100 CONTINUE + + ioptv=1 + +c HERE END OF THE LOOPS ******* +c****************************** + +C TOTAL EXTINCTION OPTICAL DEPTHS + DO 119 K=1,NSPECV +C LOOP OVER NTERMS + DO 119 NT=1,NTERM(K) + TAUV_1pt(1,K,NT)=0.0 + TAUVP_1pt(1,K,NT)=0.0 + DO 119 J=1,NLAYER + TAUV_1pt(J+1,K,NT)=TAUV_1pt(J,K,NT)+DTAUV_1pt(J,K,NT) + TAUVP_1pt(J+1,K,NT)=TAUVP_1pt(J,K,NT)+DTAUVP_1pt(J,K,NT) + 119 CONTINUE + + +c print*,'SETUP' +c do i=1,NSPECV +c print*,WLNV(i) +c do j=1,NLAYER+1 +c print*,Z(j),TAUV(1,j,i,1),WBARV(1,j,i,1),COSBV(1,j,i,1) +c enddo +c enddo +c +c IF (IPRINT .GT. 1) THEN +c NT=1 +c IF (2 .GT. 1) THEN +c WRITE (6,120) +c 120 FORMAT(///' OPTICAL CONSTANTS IN THE VISIBLE (@EQUATOR) ') +c DO 200 K=1,NSPECV +c WRITE (6,190) +c WRITE (6,210)K,WLNV(K),WNOV(K),BWNV(K) +c & ,BWNV(K)+DWNV(K),DWNV(K) +c WRITE (6,230)REALV(K),XIMGV(K) +c DO 195 J=1,NLAYER,NLAYER +c WRITE (6,220)XNUMB(J), WBARV_1pt(J,K,NT),COSBV_1pt(J,K,NT) +c & ,DTAUV_1pt(J,K,NT),TAUV_1pt(J,K,NT) +c 195 CONTINUE +c WRITE (6,240) TAUV_1pt(NLEVEL,K,NT) +c 200 CONTINUE +c END IF + +c 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) +c 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') +c 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ +c &' #AEROSOLS WBAR COSBAR DTAU TAU' +c & ,9X,'RAY GAS AEROSOL') +c 220 FORMAT(8(1X,F9.3)) +c 240 FORMAT(41X,F9.3) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/optfrac.old =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/optfrac.old (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/optfrac.old (revision 1643) @@ -0,0 +1,230 @@ + subroutine optfrac(XN,WLNV,QEXT,QSCA,QABS,CBAR) + +c------------------------------------------------------ +c +c -->( ) +c XN : NOMBRE DE MONOMERES +c WLNV : LONGUEUR D'ONDE +c ( )--> +c TEXT(NLEVEL): TAU_EXT (NLAYER) +c TSCA(NLEVEL): TAU-SCA (NLEVEL) +c TABS(NLEVEL): TAU-ABS (NLEVEL) +c CBAR(NLEVEL): PARAMETRE D'ASYMETRIE (NLEVEL) +c +c------------------------------------------------------ + + parameter(NNK=64,nmon=15,iint=5) + + + +* declaration des variables INPUT/OUTPUT +* -------------------------------------- + + real QEXT,QSCA,QABS,CBAR,XN,WLNV + + +* declaration des variables internes +* ---------------------------------- + + + real sfe(nmon,NNK),sfd(nmon,NNK),gn(nmon,NNK) + + real sfe0(nmon,NNK,iint),sfd0(nmon,NNK,iint) + & ,gn0(nmon,NNK,iint),l0(NNK) + + real xpoub,xvis,xir + integer kkk + save kkk,xvis,xir + + real ifi(NNK) + + real gi,h,h1 + + real ex(0:4) + + integer iprem + save iprem + +* declaration des blocs communs internes +*--------------------------------------- + + common/thag_thol/sfe0,sfd0,gn0,l0 + + data iprem/0/ + + + pi=3.1415926535 + + + + + +* Longueurs d'ondes et sections efficaces utilisees +*-------------------------------------------------- + + if(iprem.eq.0) THEN + print*,'APPEL OPTIQUE FRACTAL' + call agreg_tholin() + + endif + + +* restriction en longueur d'o +*---------------------------- + + if(WLNV.lt.l0(1)) stop 'WLNV < l0(1) ' + + do i=1,NNK-1 + if(WLNV.gt.l0(i)) index=i+1 + enddo + + if(WLNV.gt.l0(NNK)) stop 'WLNV > l0(NNK) ' + +commentaire: l0(index-1) < WLNV < l0(index) + + +* limite en nombre de monomeres. +*------------------------------ + + if (XN/.75.lt.1.) stop 'XN < 1' + if (XN/1.5.gt.16384.) stop 'XN > 16384' + +c......tolerance grille #1: .75 < N <1.5 +c................grille #15: 10922< N < 24576 +c................DONC .75 < N < 24576 + +* Calculs preparatoires: intervalles de longueurs d'onde +*-------------------------------------------------------- + + do j=index-1,index !longueur d'onde + ifi(j)=5 !ifi < iint + if (l0(j).lt.0.72) ifi(j)=4 + if (l0(j).lt.0.5) ifi(j)=3 + if (l0(j).lt.0.4) ifi(j)=2 + if (l0(j).lt.0.3) ifi(j)=1 + enddo + + +* l0(index) <--> l0(index-1) + if(iprem.eq.0) then + print*,'ouverture du fichier initpar' + open (unit=1,file='initpar') + read(1,*) xpoub,kkk,xvis,xir + read(1,*) + read(1,*) xpoub,kkk,xvis,xir + close(1) + print*,'ouverture du fichier initpar ok' + iprem=1 + print*,'DANS OPTFRAC' + print*,'------------' + print*,'XVIS=',xvis + print*,'XIR=',xir + endif + +c stop'Check des valeurs dans optfrac.F' + + k=int(alog(XN/.75)/alog(2.)+1.) + + xcompens=XN/(2.**(k-1)) + + + do j=index-1,index !longueur d'onde + + ifich=ifi(j) + + if (WLNV.gt.1.5) then + + sfe(k,j)=sfe0(k,j,ifich)*xir + & +sfd0(k,j,ifich)*(1.-xir) + sfd(k,j)=sfd0(k,j,ifich) + gn(k,j)=gn0(k,j,ifich) + + else + + sfe(k,j)=sfe0(k,j,ifich)*xvis + & +sfd0(k,j,ifich)*(1.-xvis) + sfd(k,j)=sfd0(k,j,ifich) + gn(k,j)=gn0(k,j,ifich) + + endif + + enddo + + + i=k + + XRAT=(WLNV-l0(index-1))/(l0(index)-l0(index-1)) + CBAR=XRAT*(gn(i,index)-gn(i,index-1)) + & +gn(i,index-1) + QEXT=XRAT*(sfe(i,index)-sfe(i,index-1)) + & +sfe(i,index-1) + QSCA=XRAT*(sfd(i,index)-sfd(i,index-1)) + & +sfd(i,index-1) + QABS=QEXT-QSCA + + QEXT=QEXT*xcompens + QSCA=QSCA*xcompens + QABS=QABS*xcompens + + + return + 500 print*,'erreur lecture initfich' + stop + 499 print*,'erreur ouverture initfich' + stop + end + + +*------------------------------------------------------------------- +* +* DEBUT DU CALCUL D'INTERPOLATION DES DONNEES AGREGAT +* +*--------------------------------------------------------------------- + + subroutine agreg_tholin() + + + common/thag_thol/qext0,qsca0,g0,l + + + parameter(nz=200,nrad=45,NNK=64,nmon=15,iint=5) + real l(NNK) + real*8 qsca,qext,qg0 + real qsca0(nmon,NNK,iint),qext0(nmon,NNK,iint) + & ,g0(nmon,NNK,iint) + + do ifich=1,iint + print*,'ouverture du fichier tetag',ifich + if (ifich.eq.1) open (unit=3,file='testag0') + if (ifich.eq.2) open (unit=3,file='testag1') + if (ifich.eq.3) open (unit=3,file='testag2') + if (ifich.eq.4) open (unit=3,file='testag3') + if (ifich.eq.5) open (unit=3,file='testag4') + print*,'ouverture du fichier ok' + + do k=NNK,1,-1 + read (3,*) l(k) + do nm=1,nmon + read (3,*) qsca,qext,qg0 +c read (3,*) qsca0(nm,k,ifich),qext0(nm,k,ifich) +c & ,g0(nm,k,ifich) + qsca0(nm,k,ifich)=sngl(qsca)*1.e-18 + qext0(nm,k,ifich)=sngl(qext)*1.e-18 + g0(nm,k,ifich)=sngl(qg0) + enddo + enddo + close (3) + + enddo +c print*,'4*>',qsca0(1,1,1),qsca0(64,15,4) + + return + end + + + +*--------------------------------------------------------------------- +* +* FIN DU CALCUL D'INTERPOLATION DES DONNEES AGREGAT +* +*--------------------------------------------------------------------- Index: trunk/LMDZ.TITAN.old/libf/phytitan/orbite.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/orbite.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/orbite.F (revision 1643) @@ -0,0 +1,52 @@ + SUBROUTINE orbite(pls,pdist_sol,pdecli) + IMPLICIT NONE + +c======================================================================= +c +c Objet: +c ------ +c +c Distance from sun and declination as a function of the solar +c longitude Ls +c +c Interface: +c ---------- +c +c common 'comorbit.h' initialized by comorbit.f +c +c Arguments: +c ---------- +c +c Input: +c ------ +c pls Ls +c +c Output: +c ------- +c pdist_sol Distance Sun-Planet in UA +c pdecli declinaison ( en radians ) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comorbit.h" + +c arguments: +c ---------- + + REAL pday,pdist_sol,pdecli,pls + +c----------------------------------------------------------------------- + +c Distance Sun-Planet + + pdist_sol=p_elips/(1.+e_elips*cos(pls+timeperi)) + +c Solar declination + + pdecli= asin (sin(pls)*sin(obliquit*pi/180.)) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/orodrag.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/orodrag.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/orodrag.F (revision 1643) @@ -0,0 +1,359 @@ + SUBROUTINE orodrag( nlon,nlev + i , kgwd, kdx, ktest + r , ptsphy + r , paphm1,papm1,pgeom1,pn2m1,ptm1,pum1,pvm1 + r , pmea, pstd, psig, pgam, pthe, ppic, pval +c outputs + r , pulow,pvlow + r , pvom,pvol,pte ) + + use dimphy + IMPLICIT NONE + +c +c +c**** *orodrag* - does the SSO drag parametrization. +c +c purpose. +c -------- +c +c this routine computes the physical tendencies of the +c prognostic variables u,v and t due to vertical transports by +c subgridscale orographically excited gravity waves, and to +c low level blocked flow drag. +c +c** interface. +c ---------- +c called from *drag_noro*. +c +c the routine takes its input from the long-term storage: +c u,v,t and p at t-1. +c +c explicit arguments : +c -------------------- +c ==== inputs === +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c pn2m1---input-R-Brunt-Vaisala freq.^2 at 1/2 layers +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + + integer nlon,nlev,kgwd + real ptsphy + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c +c pte -----output-R: T tendency +c pvom-----output-R: U tendency +c pvol-----output-R: V tendency +c +c +c Implicit Arguments: +c =================== +c +c klon-common-I: Number of points seen by the physics +c klev-common-I: Number of vertical layers +c +c method. +c ------- +c +c externals. +c ---------- +Coff integer ismin, ismax +Coff external ismin, ismax +c +c reference. +c ---------- +c +c author. +c ------- +c m.miller + b.ritter e.c.m.w.f. 15/06/86. +c +c f.lott + m. miller e.c.m.w.f. 22/11/94 +c----------------------------------------------------------------------- +c +c +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(nlon), + * pvlow(nlon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * pmea(nlon),pstd(nlon),psig(nlon), + * pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev),pn2m1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +c + integer kdx(nlon),ktest(nlon) +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer isect(klon), + * icrit(klon), + * ikcrith(klon), + * ikenvh(klon), + * iknu(klon), + * iknu2(klon), + * ikcrit(klon), + * ikhlim(klon) +c + real ztau(klon,klev+1), + * zstab(klon,klev+1), + * zvph(klon,klev+1), + * zrho(klon,klev+1), + * zri(klon,klev+1), + * zpsi(klon,klev+1), + * zzdep(klon,klev) + real zdudt(klon), + * zdvdt(klon), + * zdtdt(klon), + * zdedt(klon), + * zvidis(klon), + * ztfr(klon), + * znu(klon), + * zd1(klon), + * zd2(klon), + * zdmod(klon) + + +c local quantities: + + integer jl,jk,ji + real ztmst,zdelp,ztemp,zforc,ztend,rover + real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis + +c +c------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c print *,' in orodrag' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c +c ztmst=twodt +c if(nstep.eq.nstart) ztmst=0.5*twodt + ztmst=ptsphy +c ------------------------------------------------------------------ +c + 120 continue +c +c ------------------------------------------------------------------ +c +c* 1.3 check whether row contains point for printing +c --------------------------------------------- +c + 130 continue +c +c ------------------------------------------------------------------ +c +c* 2. precompute basic state variables. +c* ---------- ----- ----- ---------- +c* define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c + + 200 continue +c + do jk=1,klev + zstab(:,jk) = pn2m1(:,jk) + enddo +c + call orosetup + * ( nlon, nlev , ktest + * , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, zstab, pstd + * , zrho , zri , ztau , zvph , zpsi, zzdep + * , pulow, pvlow + * , pthe,pgam,pmea,ppic,pval,znu ,zd1, zd2, zdmod ) + +c +c +c +c*********************************************************** +c +c +c* 3. compute low level stresses using subcritical and +c* supercritical forms.computes anisotropy coefficient +c* as measure of orographic twodimensionality. +c + 300 continue +c + call gwstress + * ( nlon , nlev + * , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu + * , zrho , zstab, zvph , pstd, psig, pmea, ppic, pval + * , ztfr , ztau + * , pgeom1,pgam,zd1,zd2,zdmod,znu) + +c +c +c* 4. compute stress profile including +c trapped waves, wave breaking, +c linear decay in stratosphere. +c + 400 continue +c +c + + call gwprofil + * ( nlon , nlev + * , kgwd , kdx , ktest + * , ikcrit, ikcrith, icrit , ikenvh, iknu + * ,iknu2 , paphm1, zrho , zstab , ztfr , zvph + * , zri , ztau + + * , zdmod , znu , psig , pgam , pstd , ppic , pval) + +c +c* 5. Compute tendencies from waves stress profile. +c Compute low level blocked flow drag. +c* -------------------------------------------- +c + 500 continue + + +c +c explicit solution at all levels for the gravity wave +c implicit solution for the blocked levels + + do 510 jl=kidia,kfdia + zvidis(jl)=0.0 + zdudt(jl)=0.0 + zdvdt(jl)=0.0 + zdtdt(jl)=0.0 + 510 continue +c + + do 524 jk=1,klev +c + +C WAVE STRESS +C------------- +c +c + do 523 ji=kidia,kfdia + + if(ktest(ji).eq.1) then + + zdelp=paphm1(ji,jk+1)-paphm1(ji,jk) + ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp) + + zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) +c +c Control Overshoots +c + + if(jk.ge.ntop)then + rover=0.10 + if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst) + C zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst* + C zdudt(ji)/(abs(zdudt(ji))+1.E-10) + if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst) + C zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst* + C zdvdt(ji)/(abs(zdvdt(ji))+1.E-10) + endif + + rover=0.25 + zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2) + ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + + if(zforc.ge.rover*ztend)then + zdudt(ji)=rover*ztend/zforc*zdudt(ji) + zdvdt(ji)=rover*ztend/zforc*zdvdt(ji) + endif +c +c BLOCKED FLOW DRAG: +C ----------------- +c + if(jk.gt.ikenvh(ji)) then + zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2 + zc=0.48*pgam(ji)+0.3*pgam(ji)**2 + zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2 + ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/ + * (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv +c +c OPPOSED TO THE WIND +c + zdudt(ji)=-pum1(ji,jk)/ztmst + zdvdt(ji)=-pvm1(ji,jk)/ztmst +c +c PERPENDICULAR TO THE SSO MAIN AXIS: +C +cmod zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *cos(pthe(ji)*rpi/180.)/ztmst +cmod zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *sin(pthe(ji)*rpi/180.)/ztmst +C + zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet)) + end if + pvom(ji,jk)=zdudt(ji) + pvol(ji,jk)=zdvdt(ji) + zust=pum1(ji,jk)+ztmst*zdudt(ji) + zvst=pvm1(ji,jk)+ztmst*zdvdt(ji) + zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji)=zdis/ztmst + zvidis(ji)=zvidis(ji)+zdis*zdelp +c VENUS ATTENTION: CP VARIABLE + zdtdt(ji)=zdedt(ji)/rcpd +c +c NO TENDENCIES ON TEMPERATURE ..... +c +c Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation +c + pte(ji,jk)=0.0 + + endif + + 523 continue + 524 continue +c +c + 501 continue + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/orosetup.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/orosetup.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/orosetup.F (revision 1643) @@ -0,0 +1,509 @@ + SUBROUTINE orosetup + * ( nlon , nlev , ktest + * , kkcrit, kkcrith, kcrit, ksect , kkhlim + * , kkenvh, kknu , kknu2 + * , paphm1, papm1 , pum1 , pvm1, ptm1, pgeom1, pstab, pstd + * , prho , pri , ptau, pvph, ppsi, pzdep + * , pulow , pvlow + * , ptheta, pgam, pmea, ppic, pval + * , pnu , pd1 , pd2 ,pdmod ) +C +c**** *gwsetup* +c +c purpose. +c -------- +c SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME: +C DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND +C STRATIFICATION..... +c +c** interface. +c ---------- +c from *orodrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c ktest--input-I: Flags to indicate active points +c +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c VENUS ATTENTION: CP VARIABLE PSTAB CALCULE EN AMONT DES PARAMETRISATIONS +c pstab-----R-: Brunt-Vaisala freq.^2 at 1/2 layers (input except klev+1) +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c kkcrit----I-: Security value for top of low level flow +c kcrit-----I-: Critical level +c ksect-----I-: Not used +c kkhlim----I-: Not used +c kkenvh----I-: Top of blocked flow layer +c kknu------I-: Layer that sees mountain peacks +c kknu2-----I-: Layer that sees mountain peacks above mountain mean +c kknub-----I-: Layer that sees mountain mean above valleys +c prho------R-: Density at 1/2 layers +c pri-------R-: Background Richardson Number, Wind shear measured along GW stress +c pvph------R-: Wind in plan of GW stress, Half levels. +c ppsi------R-: Angle between low level wind and SS0 main axis. +c pd1-------R-| Compared the ratio of the stress +c pd2-------R-| that is along the wind to that Normal to it. +c pdi define the plane of low level stress +c compared to the low level wind. +c see p. 108 Lott & Miller (1997). +c pdmod-----R-: Norme of pdi + +c === local arrays === +c +c zvpf------R-: Wind projected in the plan of the low-level stress. + +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f.lott for the new-gwdrag scheme november 1993 +c +c----------------------------------------------------------------------- + use dimphy + implicit none + +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon) + +c + real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev), + * pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev), + * prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1), + * ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1), + * pzdep(nlon,klev) + real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon), + * pd1(nlon),pd2(nlon),pdmod(nlon) + real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c +c + integer ilevh ,jl,jk,iii + real zcons1,zhgeo,zu,zphi + real zvt1,zvt2,zdwind,zwind,zdelp + real zstabm,zstabp,zrhom,zrhop + logical lo + logical ll1(klon,klev+1) + integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon), + * kentp(klon),ncount(klon) +c + real zhcrit(klon,klev),zvpf(klon,klev), + * zdp(klon,klev) + real znorm(klon),zb(klon),zc(klon), + * zulow(klon),zvlow(klon),znup(klon),znum(klon) + +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in orosetup' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c + ilevh =klev/3 +c + zcons1=1./rd +c +c ------------------------------------------------------------------ +c +c* 2. +c -------------- +c + 200 continue +c +c ------------------------------------------------------------------ +c +c* 2.1 define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c +c +c + do 2001 jl=kidia,kfdia + kknu(jl) =klev + kknu2(jl) =klev + kknub(jl) =klev + kknul(jl) =klev + pgam(jl) =max(pgam(jl),gtsec) + ll1(jl,klev+1)=.false. + 2001 continue +c +c Ajouter une initialisation (L. Li, le 23fev99): +c + do jk=klev,ilevh,-1 + do jl=kidia,kfdia + ll1(jl,jk)= .false. + ENDDO + ENDDO +c +c* define top of low level flow +c ---------------------------- + do 2002 jk=klev,ilevh,-1 + do 2003 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr + if(lo) then + kkcrit(jl)=jk + endif + zhcrit(jl,jk)=ppic(jl)-pval(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) +C if(ll1(jl,jk).xor.ll1(jl,jk+1)) then + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu(jl)=ilevh + endif + 2003 continue + 2002 continue + do 2004 jk=klev,ilevh,-1 + do 2005 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=ppic(jl)-pmea(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk) .neqv. ll1(jl,jk+1)) then + kknu2(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh + endif + 2005 continue + 2004 continue + do 2006 jk=klev,ilevh,-1 + do 2007 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl)) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) +c if(ll1(jl,jk).xor.ll1(jl,jk+1)) then + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknub(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknub(jl)=ilevh + endif + 2007 continue + 2006 continue +c + do 2010 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kknu(jl)=min(kknu(jl),nktopg) + kknu2(jl)=min(kknu2(jl),nktopg) + kknub(jl)=min(kknub(jl),nktopg) + kknul(jl)=klev + endif + 2010 continue +c + 210 continue +c +cc* initialize various arrays +c + do 2107 jl=kidia,kfdia + prho(jl,klev+1) =0.0 +cym correction en attendant mieux + prho(jl,1) =0.0 + pstab(jl,klev+1) =0.0 + pstab(jl,1) =0.0 + pri(jl,klev+1) =9999.0 + ppsi(jl,klev+1) =0.0 + pri(jl,1) =0.0 + pvph(jl,1) =0.0 + pvph(jl,klev+1) =0.0 +cym correction en attendant mieux +cym pvph(jl,klev) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + zulow(jl) =0.0 + zvlow(jl) =0.0 + kkcrith(jl) =klev + kkenvh(jl) =klev + kentp(jl) =klev + kcrit(jl) =1 + ncount(jl) =0 + ll1(jl,klev+1) =.false. + 2107 continue +c +c* define flow density and stratification (rho and N2) +c at semi layers. +c ------------------------------------------------------- +c + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + endif + 222 continue + 223 continue +c print*,"altitude(m)=",pgeom1(kfdia/2,:) +c print*,"pression(Pa)=",papm1(kfdia/2,:) +c +c******************************************************************** +c +c* define Low level flow (between ground and peacks-valleys) +c --------------------------------------------------------- + do 2115 jk=klev,ilevh,-1 + do 2116 jl=kidia,kfdia + if(ktest(jl).eq.1) then + if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then + pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pstab(jl,klev+1)=pstab(jl,klev+1) + c +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + prho(jl,klev+1)=prho(jl,klev+1) + c +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + end if + endif + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + pvph(jl,klev+1)=znorm(jl) + pstab(jl,klev+1)=pstab(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + prho(jl,klev+1)=prho(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + endif + 2110 continue + +c +c******* setup orography orientation relative to the low level +C wind and define parameters of the Anisotropic wave stress. +c + do 2112 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec) + if(lo) then + zu=pulow(jl)+2.*gvsec + else + zu=pulow(jl) + endif + zphi=atan(pvlow(jl)/zu) + ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi + zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2 + zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2 + pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1)) + * *cos(ppsi(jl,klev+1)) + pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2) + endif + 2112 continue +c +c ************ projet flow in plane of lowlevel stress ************* +C ************ Find critical levels... ************* +c + do 213 jk=1,klev + do 212 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zvt1 =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk) + zvt2 =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk) + zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + endif + ptau(jl,jk) =0.0 + pzdep(jl,jk) =0.0 + ppsi(jl,jk) =0.0 + ll1(jl,jk) =.false. + 212 continue + 213 continue + do 215 jk=2,klev + do 214 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+ + * (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1)) + * /zdp(jl,jk) + if(pvph(jl,jk).lt.gvsec) then + pvph(jl,jk)=gvsec + kcrit(jl)=jk + endif + endif + 214 continue + 215 continue +c +c* 2.3 mean flow richardson number. +c + 230 continue +c + do 232 jk=2,klev + do 231 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec) + pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk) + * /(rg*prho(jl,jk)*zdwind))**2 + pri(jl,jk)=max(pri(jl,jk),grcrit) + endif + 231 continue + 232 continue + +c +c +c* define top of 'envelope' layer +c ---------------------------- + + do 233 jl=kidia,kfdia + pnu (jl)=0.0 + znum(jl)=0.0 + 233 continue + + do 234 jk=2,klev-1 + do 234 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + if (jk.ge.kknu2(jl)) then + + znum(jl)=pnu(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit) + * .and.(kkenvh(jl).eq.klev)) + * kkenvh(jl)=jk + + endif + + endif + + 234 continue + +c calculation of a dynamical mixing height for when the waves +C BREAK AT LOW LEVEL: The drag will be repartited over +C a depths that depends on waves vertical wavelength, +C not just between two adjacent model layers. +c of gravity waves: + + do 235 jl=kidia,kfdia + znup(jl)=0.0 + znum(jl)=0.0 + 235 continue + + do 236 jk=klev-1,2,-1 + do 236 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + znum(jl)=znup(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + znup(jl) = znup(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.) + * .and.(kkcrith(jl).eq.klev)) + * kkcrith(jl)=jk + + endif + + 236 continue + + do 237 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kkcrith(jl)=max0(kkcrith(jl),ilevh*2) + kkcrith(jl)=max0(kkcrith(jl),kknu(jl)) + if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1 + endif + 237 continue +c +c directional info for flow blocking ************************* +c + do 251 jk=1,klev + do 252 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec) + if(lo) then + zu=pum1(jl,jk)+2.*gvsec + else + zu=pum1(jl,jk) + endif + zphi=atan(pvm1(jl,jk)/zu) + ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi + endif + 252 continue + 251 continue + +c forms the vertical 'leakiness' ************************** + + do 254 jk=ilevh,klev + do 253 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pzdep(jl,jk)=0 + if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then + pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl) )-pgeom1(jl, jk))/ + * (pgeom1(jl,kkenvh(jl) )-pgeom1(jl,klev)) + end if + endif + 253 continue + 254 continue + + return + end + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/pc2h2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pc2h2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pc2h2.F (revision 1643) @@ -0,0 +1,8 @@ + FUNCTION PC2H2(T) +C THIS FUNCTION RETURNS THE VAPOR PRESSURE IN BARS. +C BASED ON A LEAST SQUARES FIT TO DATA IN TABLE III +C NBS TECHNICAL PB-151 363 + DATA A,B/21.68901,-2814.018/ + PC2H2=(1./760.)*EXP(A+B/T) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/pc2h6.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pc2h6.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pc2h6.F (revision 1643) @@ -0,0 +1,7 @@ + FUNCTION PC2H6(T) +C THIS FUNCTION RETURNS THE VAPOR PRESSURE IN BARS. +C BASED ON THE FORMULA NUMBER (7) PAGE 11 OF +C NBS TECHNICAL PB-151 363 + PC2H6=(1./760.)*10.**(8.5812- (965.4/T) ) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/pch4.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pch4.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pch4.F (revision 1643) @@ -0,0 +1,8 @@ + FUNCTION PCH4(T) +C THIS SUBROUTINE RETURNS THE VAPOR PRESSURE OF METHANE +C OVER THE TEMPERATURE INTERVAL (74-97K) IN UNITS OF BARS +C IT IS BASED ON DATA FROM THE MATHASEN GAS DATA BOOK P 351 +C FITTED BY CP MCKAY 10/85 + PCH4=3.4543E4 * EXP(-1145.705/T) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/pg2.old =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pg2.old (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pg2.old (revision 1643) @@ -0,0 +1,727 @@ + subroutine pg2( + & tpplev,tpt,tq,tdq,nq,ptimestep,mu0,fract,last) +c +c +c +c +c +c +c & tpplev,tpt,tq,tdq,nq,ptimestep,last) +c / \ +c | PHYSIQUE | AEROSOLS | +c +c \|/ +c (o o) +c-----------------oOo--O--oOo-------------------------- +c +c Interface entre physiq.F et aerosols.F +c +c Date: 5 Nov 96 +c +c -->( ) q(x,nlayer,nq) +c +c q(x,nlayer,nq) <==> c(nz,nrad) +c +c c(nz,nrad)(t) --> aerosol.F --> c(nz,nrad)(t+dt) +c +c c(nz,nrad) <==> q(x,nlayer,nq) +c +c c(IHOR,NRAD,NRAD) en aerosols +c c0(NZ,NRAD) en aerosols/m^3 +c +c L'ECHANGE N'EST POSSIBLE QUE SI LES QUANTITES SONT +c DES NOMBRES D'AEROSOLS......... +c +c LES QUANTITES Q SONT EN AEROSOLS / CASE (BOUT DE COLONNE +c DE 1m^2 * DZ(J)..................ATTENTION AU PASSAGE +c PHYSIQUE <---> DYNAMIQUE QUI A BESOINS DE ???? +c +c LE MODELE MICROPHYSIQUE A BESOIN DE CONCENTRATIONS +c AEROSOLS/M^3 +c------------------------------------------------------ + + use dimphy + USE geometry_mod, ONLY: latitude_deg +#include "dimensions.h" +#include "microtab.h" +#include "paramet.h" +#include "aerprod.h" +#include "clesphys.h" +#include "YOMCST.h" + + + parameter (NG=jjm+1) ! NG: on travaille en moyenne zonale + +c************************************* +c declaration des variables internes * +c************************************* + +c GCM * +c------------------* + + real tzzlev(ng,klev+1) + & ,tpplev(ng,klev+1) + & ,tzzlay(ng,klev) + & ,tpt(ng,klev) + & ,tq(ng,klev,nq) + & ,tdq(ng,klev,nq) + real mu0(ng),fract(ng) + + real zzlev(NG,klev+1) + & ,pplev(NG,klev+1) + & ,zzlay(NG,klev) + & ,pt(NG,klev) + & ,q(NG,klev,nq) + & ,qdel(NG,klev,nq) + & ,qcumul(NG,0:200,nq) + + integer jsup,jinf,h + + logical last + + +c microphysique * +c---------------------* + + real aire(ng),airetot,lati(ng) + save aire,lati + + real z(nz),zb(nz+1),alt(200) + real dz(nz),dzb(nz+1) + real pb(nz+1),p(nz) + real tb(nz+1),t(nz) + + real c0(200,nrad),c(nz,nrad),ctp(nz,nrad) + double precision c0lu(200,nrad) + real cmemoire(nz,nrad) + real micropas,ddt + + integer iprem + save iprem + data iprem/0/ + +c print*,'DEBUT DE PG2' + + + ngrid=ng + nlayer=klev + if(nrad.ne.nq) then + print*,'microphysique:nrad.ne.nq:',nrad,nq + stop + endif + +* ici, on evalue les niveaux d'altitudes en fonction des niveaux de +* pressions. + + do h=1,ngrid + tpplev(h,nlayer+1)=tpplev(h,nlayer)*.1 + enddo + + r=8.314*1000./28. + +* pour chaque point de grille + + do h=1,ngrid + zz=0. + tzzlev(h,1)=zz + +* bord de couche + + do l=1,nlayer + eff_g = 1.345*(2575./(2575.+zz/1000.))**2 + zz=zz+r*2.*tpt(h,l)/ + & eff_g*(tpplev(h,l)-tpplev(h,l+1))/(tpplev(h,l)+tpplev(h,l+1)) + tzzlev(h,l+1)=zz +c print*,l,eff_g,tpplev(h,l),tpplev(h,l+1),zz + enddo + +* milieu de couche + + do l=1,nlayer + xlog=( alog(tpplev(h,l+1)) + alog(tpplev(h,l)) )/2. + rapport=(tzzlev(h,l+1)-tzzlev(h,l)) + & /(alog(tpplev(h,l+1))-alog(tpplev(h,l))) + tzzlay(h,l)=rapport*(xlog-alog(tpplev(h,l+1))) + & +tzzlev(h,l+1) + enddo + enddo + + +c PRINT*,'PROFILE #1' +c h=10 +c do l=1,nlayer +c print*, tpplev(h,l),tpt(h,l),tq(h,1,1),tq(h,l,7) +c enddo +c print*, tpplev(h,nlayer+1) + + do j=1,200 + alt(j)=(j-1)*5000. !0 5000 10000 15000 .......! + enddo + + + + +c ************************** +c INITIALISATION DE TABLEAUX +c ************************** +c A NE FAIRE QU'UNE FOIS +c ************************** + + + IF (iprem.eq.0) THEN + + qdel = 0. + +c initialisation de aire(ig) +c -------------------------- + + airetot=0. + + lati(1) = 0.5*RPI + DO ig=2,ngrid-1 + lati(ig) = latitude_deg(2+(ig-2)*iim)*RPI/180. + ENDDO + lati(ngrid) = -0.5*RPI + + DO ig=1,ngrid + if(ig.eq.1) + & aire(ig)=2*RPI*(1.-sin(lati(ig)/2.+lati(ig+1)/2.))*RA*RA + if(ig.eq.ngrid) + & aire(ig)=2*RPI*(1.+sin(lati(ig-1)/2.+lati(ig)/2.))*RA*RA + if(ig.ne.1. .and. ig.ne.ngrid) aire(ig)=2*RPI*RA*RA* + & (sin(lati(ig-1)/2.+lati(ig)/2.) + & -sin(lati(ig)/2.+lati(ig+1)/2.)) + + airetot=airetot+aire(ig) + ENDDO +c print*,"ENTREE PG2 PREMIER APPEL" +c print*,airetot,' airetot?= ',4.*RPI*RA*RA +c print*,1,latitude_deg(1),aire(1),aire(1)/airetot,' aires' +c DO ig=2,ngrid-1 +c print*,ig,latitude_deg(2+(ig-2)*iim),aire(ig),aire(ig)/airetot,' aires' +c ENDDO +c print*,ngrid,latitude_deg(klon),aire(ngrid),aire(ngrid)/airetot,' aires' +c stop + +c initialisation de c(z,r) +c -------------------------- + + + itype=2 + + +c remplissage type 1: OBSOLETE ! +c---------------------- + + + if(itype.eq.1) then !**************************** + + taer=tcorrect + +#ifdef CRAY + open (unit=32,file='aerosols',status='old',iostat=ii, + 1 form='formatted') + if(ii.ne.0) then + print*,'WARNING!!! pas de reinitialisation des traceurs' + print*,'On part des traceurs contenus dans start' + return + endif + print*,'pg2 apres open version cray',ii + read(32,'(e8.3)') tt + read(32,'(5e10.3)') c0 + close(32) +#else + print*,'pg2 avant open' + open (unit=31,file='initfich',iostat=ii, + 1 access='sequential',form='formatted') + +13 read(unit=31,fmt=1010,iostat=ii,end=15)tt,((c0lu(j,k), + 1 k=1,nrad),j=1,200) +1010 format(e8.3,2000(e8.3)) + +15 continue + +c Conversion: lecture en double, variable utile en simple... + do j=1,200 + do k=1,nrad + c0(j,k) = real(c0lu(j,k)) +c print*,c0(j,k) + enddo + enddo +#endif + +c print*,'fichier microphysique' +c do j=1,200 +c print*,'L&0',j,c0(j,1),c0(j,3),c0(j,5),c0(j,7),c0(j,9) +c enddo + + close (unit=31) + + do k=1,nrad + do h=1,ngrid + qcumul(h,0,k)=0. + qcumul(h,1,k)=c0(200,k)*taer*5000. + do j=2,200 + qcumul(h,j,k)=c0(200-j+1,k)*taer*5000.+qcumul(h,j-1,k) + enddo + do j=1,nlayer + qdel(h,j,k)=tq(h,j,k) ! etat q provenant des starts a effacer! + tq(h,j,k)=0. + enddo + enddo + enddo +c do j=1,200 +c print*,'L&1',j,qcumul(12,j,1),qcumul(12,j,3),qcumul(12,j,5) +c enddo + write(92,*) qdel + +c interpolation des q_cumules + +c do j=1,nlayer +c print*,tzzlev(10,j),alt(j) +c enddo + do k=1,nrad + do h=1,ngrid + jsup=int(tzzlev(h,2)/5000.+2.) + xfact=tzzlev(h,2)/alt(jsup) + tq(h,1,k)=xfact*qcumul(h,1,k) + do j=2,nlayer + jsup=int(tzzlev(h,j+1)/5000.+2.) + jinf=int(tzzlev(h,j+1)/5000.+1.) + xfact=(tzzlev(h,j+1)-alt(jinf))/(alt(jsup)-alt(jinf)) + tq(h,j,k)=xfact*(qcumul(h,jsup-1,k)-qcumul(h,jinf-1,k)) + & +qcumul(h,jinf-1,k) + enddo + enddo + enddo + +c soustraction des q_cumules + + do k=1,nrad + do h=1,ngrid + do j=nlayer,2,-1 + tq(h,j,k)=tq(h,j,k)-tq(h,j-1,k) + enddo + enddo + enddo + +c on inverse q <--> tq, et tq=0 ====> dq=q-qt a la fin pour intitialiser. + + do k=1,nrad + do h=1,ngrid + do j=nlayer,1,-1 + q(h,j,k)=tq(h,nlayer-j+1,k) + tq(h,nlayer-j+1,k)=0. + +c if (h.eq.12) then +c if (k.eq.nrad) then +c print*,'L&3',j,q(12,j,1),q(12,j,3),q(12,j,5) +c endif +c endif + + enddo + enddo + enddo + print*,'itype=1' + + do h=1,ngrid + somme=0. + do k=1,nrad + do j=nlayer,1,-1 + ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1)) + somme=somme+q(h,j,k)*4.1888*ref**3. + enddo + enddo + print*,'bilan externe: m3/m2 grid#',h, somme + enddo + + + else !********************************** + +c remplissage type 2: +c---------------------- + +c open (unit=31,file='finfich',iostat=ii, +c 1 access='sequential',form='formatted') + +c read(unit=31,fmt=1011,iostat=ii,end=18)tt,(((q(i,j,k), +c 1 k=1,nrad),j=1,nlayer),i=1,ngrid) +c8 continue +c close (unit=31) +c---------------------- + + + print*,'entre dans itype2' + + + do k=1,nrad + do h=1,ngrid + do j=nlayer,1,-1 + + + + q(h,nlayer+1-j,k)=tq(h,j,k)*tcorrect + + tq(h,j,k)=0. +c +c Car les q initiaux sont lus dans la physiq, mais les dq doivent +c etre passes dans la dynamique via dqfi. C'est ici que les valeurs +c de dqfi=(q_lu*tcorrect - 0) sont definie + + enddo + enddo + enddo + + + print*,'itype=2' + do h=1,ngrid + somme=0. + do k=1,nrad + do j=nlayer,1,-1 + ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1)) + somme=somme+q(h,j,k)*4.1888*ref**3. + enddo + enddo + print*,'bilan externe: m3/m2 grid#',h, somme + enddo + + + + + + endif + + + ENDIF !FIN IPREM + + + +c ************************************ +c FIN: A NE FAIRE QU'UNE FOIS +c ************************************ +c + + + +c ************************************ +c IL FAUT INVERSER LES TABLEAUX... +c ************************************ + + + + + do n=1,ngrid + do j=1,NLAYER+1 ! j de 1 a 120 + zzlev(n,j)=tzzlev(n,nlayer-j+2) ! indice de 120 a 1 + pplev(n,j)=tpplev(n,nlayer-j+2) + enddo + enddo + +c les tq() doivent etre en nombre d'aerosols / cases + + do j=1,NLAYER ! j de 1 a 119 + do n=1,ngrid + zzlay(n,j)=tzzlay(n,nlayer-j+1) ! indice de 119 a 1 + pt(n,j)=tpt(n,nlayer-j+1) + enddo + enddo + + if (iprem.eq.0) goto 119 ! pour ne pas effacer les q()|t=0 + + do j=1,NLAYER ! j de 1 a 119 + do n=1,ngrid + do i=1,nq + qdel(n,j,i)=0. + q(n,j,i)=tq(n,nlayer-j+1,i) + enddo + enddo + enddo + + 119 continue + + +c ****************************** +c BILAN DE MASSE +c ****************************** + + total=0. + do ihor=1,ngrid + do iq=1,nq + do JALT=1,nlayer + total=total+tq(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor) + enddo + enddo + enddo +c print*,'Bilan entree masse des qaer (unite M_mono)',total + + +c**************************************** +c * +c ADAPTATION GCM > micro * +c * +c**************************************** + + +c correpondance des couches / sens GCM > microphysique +c----------------------------------------------------- +c +c But remplir les c(nz,i) avec les concentrations +c Q(ng,NLAYER,i) d'aerosols calculee par gcm.F + + + + totalc1=0. + totalc2=0. + + if (iprem.eq.0) then +c ici, les tableaux definissant la structure des aerosols sont +c remplis: rf,df(nq),rayon(nq,)v(nq)...... + call rdf() + endif + + + +c--------------------------------------------- + + IF (iprem.eq.0) goto 102 + +c !! La premiere fois, on ne passe pas par +c !! q--->c et par pg3.F +c !! on passe directement au remplissage c-->q +c--------------------------------------------- + + + do IHOR=1,NGRID ! GRANDE BOUCLE HORIZONTALE + + cpt=0. + cpx=0. + nzhau=0 + + + do JALT=1,nlayer-1 ! 1ere BOUCLE SUR Z (indice nz=1,120) + dz(jalt)=(zzlay(ihor,jalt)-zzlay(ihor,jalt+1)) + enddo + dz(nlayer)=dz(nlayer-1) ! ARBITRAIRE ET SANS IMPORTANCE!!!!! + + do JALT=1,nlayer ! 1ere BOUCLE SUR Z (indice nz=1,120) + dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1)) + pb(jalt)=pplev(ihor,jalt) + t(jalt)=pt(ihor,jalt) + enddo + pb(nlayer+1)=pplev(ihor,nlayer+1) + + + +c** T(>300km) = T(300km) + + + pb(nlayer+1)=pplev(IHOR,nlayer+1) + + zb1=zzlev(ihor,1) + z1 =zzlay(ihor,1) + + +c if(ihor.eq.12) +c & print*,'nzhau pour la latitude # ',ihor,' : ',nzhau +c if(ihor.eq.1) +c & print*,'nzhau pour la latitude # ',ihor,' : ',nzhau +c if(ihor.eq.24) +c & print*,'nzhau pour la latitude # ',ihor,' : ',nzhau + + +c Interpolation des tableaux tb et p a partir de t et pb +c****************************************************** + + do i=1,nz-1 + tb(i+1)=(t(i)+t(i+1))/2. ! temperature au bord des couches + enddo + + tb(1)=t(1) + tb(nz+1)=(t(nz)-t(nz-1))*.5+t(nz) + + do i=1,nz + p(i)=(alog(pb(i))+alog(pb(i+1)))/2. ! pression au centre des couches + p(i)=exp(p(i)) + enddo + + + +c**************************************** +c +c APPEL DU MODEL MICROPHYSIQUE +c +c**************************************** + + + do i=1,nrad + do j=1,nz + c(j,i)=q(IHOR,j,i)/dzb(j) ! concentration aerosols/m^3 + enddo + enddo + +c ------- +101 continue + + + ddt=0. + micropas=min(36000.,ptimestep) +103 micropas=micropas/2. + ddt=ptimestep/(int(ptimestep/(2*micropas))*1.)/2. + if (int(ptimestep/ddt/2.).lt.2) goto 103 + + call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt + & ,nzhau,ihor,mu0(ihor),fract(ihor)) + + + do i=1,nrad + do j=1,nz + totalc2=totalc2+c(J,i)*dzb(j) + & *2.**(i*7.-7.) + q(IHOR,j,i)=c(j,i)*dzb(j) ! nombre aerosols + enddo + enddo + + ENDDO ! Fin de la boucle IHOR + + +102 CONTINUE ! la premiere fois, c'est une boucle vide! + + + +c*************************************************************** +c FIN: on renvoie les nouvelles valeurs de dq=q(t+dt)-q(t) +c*************************************************************** + + + + + do n=1,ngrid + do i=1,nq + do j=1,NLAYER ! j de 1 a 54 + + + tdq(n,nlayer+1-j,i)=0. + + tdq(n,nlayer+1-j,i)=(q(n,j,i) + & -tq(n,nlayer+1-j,i))/ptimestep + + if (tdq(n,nlayer+1-j,i).eq.0.) tdq(n,nlayer+1-j,i)=1.e-20 + enddo + enddo + enddo + +c Calcul de la surface des aerosols pour la chimie heterogene +c------------------------------------------------------------- + + do ihor=1,ngrid + do jalt=1,nlayer + + dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1)) + psurfhaze(ihor,jalt)=0. + + do iq=1,nq + if(iq .le. 6) + & surf1=4.*3.1415926353*rf(6)**2./(2.519842**(6-iq))**2. + if(iq .gt. 6) + & surf1=4.*3.1415926353*rf(6)**2. * (16.**(iq-6)) + + psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt)+ + & q(ihor,nlayer+1-jalt,iq)/dzb(jalt)*surf1 + enddo + + psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt) + & *1.e12/1.e6 !passage m^2/m^3 a um^2/cm^3 +c print*,psurfhaze(ihor,jalt),dzb(jalt),q(ihor,nlayer+1-jalt,1) +c & ,surf1,rf(6) + + enddo + enddo + +c***** WARNING, SI IPREM=0 ON DOIT EGALEMENT SOUSTRAIRE QDEL +c******* VOIR PLUS LOIN. DANS CE CAS, LA BOUCLE SI DESSUS +c****** NE SRT QU'A FAIRE LE BIALN DQ=Q_FICHIER-0 +c**** LE DQ EFFECTIVEMENT PRIS EN COMPTE EST CALCULE APRES LE BILAN + +c BILAN DE MASSE SORTIE + + + total=0. + tmass=0. + do ihor=1,ngrid + do iq=1,nq + do JALT=1,nlayer + total=total+tdq(ihor,JALT,iq)*(16.**(iq-5)) + . *aire(ihor)*ptimestep + tmass=tmass+q(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor) + enddo + enddo + enddo +c print*,'Bilan sortie masse des qaer (unite M_mono)', +c . tmass,total,total/tmass + + +c POUR LE PREMIER PASSAGE, IL FAUT ELIMINER L'ETAT DE Q +c PROVENANT DE LA LECTURE DES FICHIERS STARTS +c QD DOIT DONC CONTENIR -QDEL + + if (iprem.eq.0) then + + do n=1,ngrid + do i=1,nq + do j=1,NLAYER ! j de 1 a 54 + + tdq(n,nlayer+1-j,i)=0. + + tdq(n,nlayer+1-j,i)=(q(n,j,i) + & -tq(n,nlayer+1-j,i) + & -qdel(n,nlayer+1-j,i))/ptimestep + + + tq(n,nlayer+1-j,i)=tq(n,nlayer+1-j,i)+qdel(n,nlayer+1-j,i) + + if (tdq(n,nlayer+1-j,i).eq.0.) tdq(n,nlayer+1-j,i)=1.e-20 + + enddo + enddo + enddo + endif + +c print*,'ok1' +c EN GENERAL, TDQ= (Q_FICHIER - Q_START)/PTIMESTEP + + + iprem=1 ! LA PROCHAINE FOIS NE SERA PLUS LA 1ERE +c print*,'************************************' +c print*,'***********TABLEAU APRES************' +c print*,'************************************' +c do h=12,12 +c do j=1,NLAYER +c print*,'exit',h,j,tdq(h,j,7),q(h,j,7),tpt(h,j),tpplev(h,j) +c enddo +c enddo +c print*,'************************************' + +c Au dernier appel...on ecrit finfich + + if (last) then + open (unit=31,file='finfich',iostat=ii, + 1 access='sequential',form='formatted') + + + write(unit=31,fmt=1011,iostat=ii)tt,(((q(i,j,k), + 1 k=1,nrad),j=1,nz),i=1,ngrid) + endif +c print*,'ok2' + +1011 format(e8.3,21000(e8.3)) + + + 16 return + 500 print*,'erreur lecture initfich' + stop + 499 print*,'erreur ouverture initfich' + stop + end + + +c--------------------------------------------------------------------- Index: trunk/LMDZ.TITAN.old/libf/phytitan/pg3.old =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pg3.old (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pg3.old (revision 1643) @@ -0,0 +1,1530 @@ + subroutine pg3(tab1,tab2,tab3,tab4,tab5,tab6,tab7, + & x1,x2,x3,x4,xnztop,ihor,xmu0,xfract) + +c call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt +c & ,nzhau,ihor) + + +*1 dz, pas d'altitude pour les milieux de couches +*2 dzb, pas d'altitude pour les limites superieures de couches +*34 tb,t temperature a la limite superieure des couches et +*4 au milieu des couches +*56 pb,p pression a la limite superieure des couches et +*6 au milieu des couches +*7 c nombre de particules de la grille de rayon r a l'altitude z +*1 z1, altitude du milieu de la couche superieure de l'atmosphere. +*2 zb1, altitude de la limite superieure de la couche superieure +* de l'atmosphere +*3 tmax, duree , en jour, de l'execution +*4 dt, pas de temps, en heure. + +*--------------------------------------------------------------* +* * +* ENTRE 0 ET 1000 KILOMETRES * +* * +* la dimension fractale est en tableau, attention au * +* raccordement entre le regime moleculaire et le regime * +* fluide * +* * +* Modele microphysique: Cabane et al.,1992 / * +* Modele version fractale: Cabane et al.,1993 / * +* * +*--------------------------------------------------------------* +* VERSION DU 2 JUIN 1993 --- AUT 1994 --- 11/04/96 +* +* changer: altitude de production zalt0=/taux de production ctot= +* : la charge/micron, ne +* : df(h),rf... +* raccordement aknc +* +* declaration des blocs communs +*------------------------------ + +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/ini/z1,zb1,c0 + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + common/coag/k + common/effets/ xsaison + + +* declaration des variables communes +* ---------------------------------- + + integer xnztop + integer li,lf + real dt,tt + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz) + & ,pb(nz),tb(nz),rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + real c0(nz,nrad),c(nz,nrad,2) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + real k(nz,nrad,nrad),knu + real xmu0,xfract + + +* variables internes +* ------------------ + + integer h,ti,tmax,itime + real tab1(nz),tab2(nz+1),tab3(nz+1),tab4(nz) + real tab5(nz+1),tab6(nz),tab7(nz,nrad) + real x1,x2,x3,x4 + real knd1,knd2,knd3,knd4,knd5,knd6 + + save itime + data itime/0/ +* initialisation +* -------------- + +c print*,'Df aerosols /1 a nqtot/' +c write(*,*) (df(h),h=1,nrad) +c write(*,*) (rayon(h),h=1,nrad) +c write(*,*) (dr(h),h=1,nrad) +c write(*,*) (v(h),h=1,nrad) +c write(*,*) (dv(h),h=1,nrad) +c print*,vrat,rf,aknc + +* effet saisonnier +* ---------------- + + + xsaison=0. + xsaison=xmu0*4.*xfract + !=Pi si fract=1/2 (equinoxe) et + ! si mu0=1 sous le soleil + ! exactement. + +c xsaison=0. +c if (ihor.le.9.or.ihor.ge.41) xsaison=8. ! rapport des surfaces +c xsaison=1. + +* controles +* --------- + + do i=1,nz + dz(i)=tab1(i) + dzb(i)=tab2(i) + tb(i)=tab3(i) + t(i)=tab4(i) + pb(i)=tab5(i) + p(i)=tab6(i) + do j=1,nrad + c(i,j,1)=tab7(i,j) + c(i,j,2)=0.0 + enddo + enddo + z1=x1 + zb1=x2 + tmax=int(x3/x4)/2 ! 2. * tmax iterations + dt=x4 ! + + + z(1)=z1 + zb(1)=zb1 + + do 12 i=2,nz + z(i)=z(i-1)-dz(i-1) + zb(i)=zb(i-1)-dzb(i-1) +12 continue + +c print*, tmax,dt,z1,zb1 +c do i=1,nz +c print*,i,z(i),p(i),t(i),zb(i),pb(i),tb(i),c(i,1,1) +c enddo + +c stop 'profile' + + if (itime.eq.0) then + + ITIME=1 +c print*,'avant init' + call init +c print*,'apres init' +c print*,'avant calcoag' + call calcoag +c print*,'apres calcoag' + +c print*,'***** TEST COAGULATION ********' +c do h=1,nz,20 +c do i=1,3 +c print*,'KOAG',h,i,k(h,1,i),k(h,2,i),k(h,3,i) +c enddo +c enddo + + endif + + +* iteration du modele sur le temps +* --------------------------------- +c print*,'##############################################' +c print*,'debut microphysique' +c print*,'Df aerosols /1 a 6/' +c write(*,*) (df(h),h=1,6) +c call ecran(tt) +c +c print*,'CHECK BEFORE COMPUTATION' +c print*,'nrad=',nrad,' nqtot=',nqtot,' ctrl...' +c print*,'##############################################' +c print*,'1.0 - tableaux de bases:' +c print*,'i rayon(i) ' +c do i=1,nrad +c print*,i,rayon(i) +c enddo +c print*,'temps appel pas de temps:' +c print*,tmax, dt +c print*,'##############################################' +c print*,'1.1 - Avec l altitude: ' +c print*,' i v1 v3 v5 v6 ' +c print*, 'i z(i) c(i,1,1) c(i,4,1) c(i,6,1)' +c print*,'*** dz(i) dzb(i)' +c print*,'*** pb(i) p(i) t(i) tb(i)' +c +c if(ihor.eq.25.or.IHOR.EQ.1.) THEN +c do i=1,nz,1 +c print*,i,z(i),c(i,1,1),c(i,4,1),c(i,6,1) +c print*,'pbpttb',pb(i),p(i),t(i),tb(i) +c v1=vitesse(i,7,0) +c v2=vitesse(i,8,0) +c v3=vitesse(i,9,0) +c v4=vitesse(i,10,0) +c print*,ihor,z(i),v1,v2,v3,v4 +c enddo +c endif +c if(ihor.eq.25) STOP +c +c if (ihor.eq.25.or.ihor.eq.48.or.ihor.eq.1) then +c print*,'##############################################' +c print*,'ihor=',ihor +c do i=1,nz,1 +c knd1=knu(i,5,1) +c knd2=knu(i,6,1) +c knd3=knu(i,7,1) +c knd4=knu(i,8,1) +c knd5=knu(i,9,1) +c knd6=knu(i,10,1) +c print*,i,z(i),knd2,knd4,knd6 +c enddo +c +c if(ihor.eq.49) STOP +c +c endif +c +c print*,'1.2 - Avec les rayons:' +c print*,'h i j k(h,i,j)' +c do j=1,nqtot +c print*,h,i,j,k(h,i,j) +c enddo +c print*,'##############################################' +c stop 'end check' + + +c somme=0. +c do i=1,nz +c do j=1,nrad +c somme=somme+c(i,j,1)*dzb(i)*4.1888*rayon(j)**3. +c enddo +c enddo + +c print*,'bilan interne: ',somme,' volume/m^2' + + + ! 1,tmax,2*dt : + do 10 ti=1,tmax ! a chaque passage, deux pas + ! de temps sont franchis.... +* 1ere iteration + + tt=tt+dt + + call coagul + + call production(ihor) + +c call nuages + + li=3-li + lf=3-lf + + call sedif + + + + +* 2ieme iteration + + tt=tt+dt + + li=3-li + lf=3-lf + + + call sedif + + li=3-li + lf=3-lf + + call coagul + + call production(ihor) + +c call nuages + + li=3-li + lf=3-lf + + + +10 continue + +379 continue + + do i=1,nz + do j=1,nrad + tab7(i,j)=c(i,j,li) ! li=1 + enddo + enddo + +c total=0. +c do i=1,nz +c do j=1,nrad +c total=total+tab7(i,j)*dzb(j)*rayon(j)**3. +c & *(1.333333*3.1415926)*1000. +c enddo +c enddo +c print*,'bilan colonne kg/m^2:',total + + +777 return + + end +*________________________________________________________________________ + subroutine ecran(tt) + +#include "dimensions.h" +#include "microtab.h" +cparameter(nz=200,nrad=nqtot,nztop=135) + common/con/c + real c(nz,nrad,2) + print*,'--------------------' + print*,'ecriture micro:' + do i=140,200,20 + print*, c(i,1,1),c(i,4,1),c(i,6,1) + enddo + + return + end + + + + + subroutine coagul + + +********************************************************* +* ce programme calcule la nouvelle concentration dans * +* le a ieme intervalle de rayon, a l'altitude h, a * +* l'instant t+dt * +********************************************************* + +#include "dimensions.h" +#include "microtab.h" + +* declaration des blocs communs +*------------------------------ + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + +* declaration des variables +* -------------------------- + + integer li,lf + real tt,dt +cparameter(nz=200,nrad=nqtot,nztop=135) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav + real pb(nz),tb(nz),rhob(nz) + real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz) + real vrat,dr(nrad),dv(nrad) + real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,a + real pr,pe + +* traitement +* ---------- + + + do 10 h=nztop,nz + do 11 a=1,nrad + call pertpro(h,a,pe,pr) +c if((1+dt*pe).lt.0.) stop 'denom.eq.0' + c(h,a,lf)=(c(h,a,li)+pr*dt)/(1+dt*pe) + +11 continue +10 continue + + if (nztop.ne.1) then + do 12 h=1,nztop-1 + do 12 a=1,nrad + c(h,a,lf)=c(h,a,li) +12 continue + endif + + return + end + + +*__________________________________________________________________________ + + subroutine calcoag + +*************************************************************** +* * +* Ce programme calcule les coefficients de collection d'une * +* particule de rayon x avec une particule de rayon b a une * +* altitude donnee h * +*************************************************************** + +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + common/coag/k + +* declaration des variables +* -------------------------- + + integer li,lf + real tt,dt +cparameter(nz=200,nrad=nqtot) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav + real pb(nz),tb(nz),rhob(nz) + real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz) + real vrat,dr(nrad),dv(nrad) + real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) + real knu,nud,k(nz,nrad,nrad) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,x + real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg + real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb + real*8 ne,qe,epso + real*8 corelec,yy + + real kco,vx,vb,vitesse,sto,ee,a,dd,bb,p0,t0,l0,ccol + real st(37),ef(37) + +* initialisation +* -------------- +c print*,'**** calcoag' + +* -nombres de STOCKES + + data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1, + s 3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9, + s 10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86., + s 187.,600./ + +* -coef. d'efficacite de collection + + ef(1)=3.75 + ef(2)=8.75 + do 11 i=3,37 + ef(i)=ef(i-1)+2.5 +11 continue + + do 2 i=1,37 + ef(i)=ef(i)*1e-2 +2 continue + + qe=1.6e-19 + ne=-30e+6 + epso=1e-9/(36*pi) + + d=1.257 + e=0.4 + f=-1.1 + +* iteration sur z + + do 1 h=1,nz + nua=nud(h,1) + +* iteration sur les rayons + + do 1 b=1,nrad + + knb=knu(h,b,1) + vb=vitesse(h,b,1) + + do 1 x=1,b + + knx=knu(h,x,1) + vx=vitesse(h,x,1) + + + +** COAGULATION **************************************************** +** --------------**************************************************** +* calcul du terme correcteur 'slip-flow' + + alphab=d+e*exp(f/knb) + alphax=d+e*exp(f/knx) + +* calcul du coefficient de diffusion + + rfb=(rayon(b)**(3./df(b)))*((rf(b))**(1.-3./df(b))) + rfx=(rayon(x)**(3./df(x)))*((rf(x))**(1.-3./df(x))) + db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb) + dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx) + +* calcul du coefficient de coagulation + + + rpr=rfb+rfx + kcg=4*pi*rpr*(db+dx) + +* calcul de la vitesse thermique + + gx=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(x)**3)) + gb=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(b)**3)) + +* calcul du libre parcours apparent des aerosols + + lambb=8*db/(pi*gb) + lambx=8*dx/(pi*gx) + +*calcul du terme correcteur beta + + rm=rpr/2. + dm=(dx+db)/2. + g=sqrt(gx**2+gb**2) + deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5) + s /(6*rfb*lambb)-2*rfb)*sqrt(2.) + deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5) + s /(6*rfx*lambx)-2*rfx)*sqrt(2.) + del=sqrt(deltab**2+deltax**2) + beta=1/((rm/(rm+del/2))+(4*dm/(g*rm))) + +* calcul du coefficient de coagulation corrige + + kcg=kcg*beta + + + + + +** COALESCENCE ************************************************** +** -------------************************************************** + + + kco=0. + + if ( b.eq. x) goto 9 + + +* calcul du nombre de Stockes de la petite particule + + sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb) + +* calcul du coef. de Cunningham-Millikan + + a=1.246 + bb=0.42 + dd=0.87 + l0=0.653e-7 + p0=101325. + t0=288. + + ee=1+(l0*t(h)*p0*(a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0)))) + s /(rfx*t0*p(h)) + +* calcul du nombre de Stockes corrige + + sto=sto*ee + + if (sto .le. 1.2) goto 9 + + if (sto .ge. 600.) then + ccol=1. + goto 8 + endif + +* recherche du coefficient de collection + + do 3 i=1,37 + if (sto .gt. st(i)) then + goto 3 + endif + + if (sto .eq. st(i)) then + ccol=ef(i+1) + else + ccol=ef(i) + endif + goto 8 +3 continue + +* calcul du coefficient de coalescence + +8 kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx) + +9 continue + +** CORRECTION ELECTRICITE ******************************* +** ------------------------****************************** + + + yy=1.d0*ne**2*rayon(x)*rayon(b)*qe**2 + & /(1.d0*kbz*t(h)*(rayon(b)+rayon(x))*4*pi*epso) + + corovo=1 + corcoll=1. ! efficacite de collage + + corelec=0. + if (yy.lt.50.) corelec=yy/(exp(yy)-1.) + + k(h,b,x)=(kcg+kco)*corelec*corovo*corcoll + k(h,x,b)=k(h,b,x) + + +1 continue + return + end + +*______________________________________________________________________ + + real function lambda(j,indic) +* +*------------------------------------------------------------------* +* fonction calculant le libre parcours moyen des molecules * +* atmospheriques( rayon =ra) se trouvant dans la couche no j. * +* pour indic=0 ...... la particule se trouve a la frontiere entre* +* les couches j et j-1 * +* pour indic=1 ...... la particule se trouve au milieu de la * +* la couche j * +*------------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + +* declaration des variables communes +* ---------------------------------- + +cparameter(nz=200,nrad=nqtot) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz), + s rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + +* declaration des variables internes +* ---------------------------------- + + integer indic + real pp,ra + + ra=1.75e-10 + +* traitement +* ---------- + + if (indic.eq.0) then + pp=pb(j) + else + if (indic.ne.1) then + print*,'erreur argument fonction lambda' + return + endif + pp=p(j) + endif + + lambda=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp) + end + +******************************************************************************* + + real function knu(j,k,indic) +* +*--------------------------------------------------------------* +* fonction calculant le nombre de knudsen d'une particule * +* d'aerosol de rayon rayon(k) se trouvant dans la couche no j * +* indic ...... idem function lambda * +*--------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/part/v,rayon,vrat,dr,dv + +* declaration des variables communes +* ---------------------------------- + +cparameter(nz=200,nrad=nqtot) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + +* declaration des variables internes +* ---------------------------------- + + integer indic + real lambda + +* traitement +* ---------- + + if (indic.ne.0 .and.indic.ne.1) then + print*,'erreur argument fonction knu' + return + endif + + rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k))) + knu=lambda(j,indic)/rfk + end + +***************************************************************************** + + real function nud(j,indic) +* +*--------------------------------------------------------------* +* fonction calculant la viscosite dynamique (en USI) de l'air * +* d'apres la formule de Sutherlant a l'altitude j * +* indic ......... idem fonction lambda * +*--------------------------------------------------------------* +* +#include "dimensions.h" +#include "microtab.h" + integer indic +cparameter (nz=200) + real nud0,c,tt + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz), + s rhob(nz) + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob +* + nud0=1.74e-5 + c=109. + + if(indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction nud' + return + endif + + if(indic.eq.0) tt=tb(j) + if (indic.eq.1) tt=t(j) + + nud=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt) + end + +**************************************************************************** + + real function vitesse(j,k,indic) +* +*-----------------------------------------------------------------* +* fonction calculant la vitesse de chute d'une particule de rayon* +* k se trouvant a l'altitude j suivant la valeur du nombre de * +* Knudsen * +* indic ....... idem function lambda * +*-----------------------------------------------------------------* +* + +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/part/v,rayon,vrat,dr,dv + +* declaration des variables communes +* ---------------------------------- + +cparameter(nz=200,nrad=nqtot) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz) + s ,pb(nz),tb(nz),rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + +* declaration des variables internes +* ---------------------------------- + + integer indic + real w,g,m,a0,zz,knu,nud,knud,tt,rhoh + +* traitement +* ---------- + + if (indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction vitesse' + return + endif + + if(indic.eq.0) then + zz=z(j)+dz(j)/2. + tt=tb(j) + rhoh=rhob(j) + endif + if(indic.eq.1) then + zz=z(j) + tt=t(j) + rhoh=rho(j) + endif + + g=g0*(rtit/(rtit+zz))**2 + a0=0.74 + m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav + knud=knu(j,k,indic) + + + akncx=aknc + if(df(k).gt.2.5) akncx=2.7 + + if(knud.ge.akncx) then + + rbis=(rayon(k)**(3.-6./df(k)))*((rf(k))**(-2.+6./df(k))) + w=a0*g*rbis*rhol/(rhoh*sqrt(8*kbz*tt/(pi*m))) + endif + + if(knud.lt.akncx) then + + rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k))) + w=2./9.*rfk**(df(k)-1.)*rf(k)**(3.-df(k))*g*rhol/nud(j,indic) + + if(knud.gt.0.01) w=w*(1+knud) + endif + +c if (p(j).lt.500..and.k.eq.nrad) then +c w=0. +c endif + + + + vitesse=w + end +*********************************************************************** + + real function kd(h) +* +*--------------------------------------------------------------------* +* cette fonction calcule le coefficient du terme de 'eddy diffusion'* +* a l'altitude j * +*--------------------------------------------------------------------* +* + +#include "dimensions.h" +#include "microtab.h" + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + + +cparameter(nz=200,nrad=nqtot) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz), + s rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + + integer h + + zbx=z(h)+dz(h)/2. + if(zbx.le.42000.) then + kd=4. + kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + else +c kd=1.e+15*(pb(h)/(kbz*tb(h)))**(-2./3.) + kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + endif + + kd=0.0*kd + + return + end + + +*____________________________________________________________________________ + + subroutine init +* +*--------------------------------------------------------------------* +* cette routine effectue : * +* 1) interpolation a partir des donnees initiales des * +* valeurs de p,t,rho,ach4,aar,an2 sur la grille * +* 2) initialisation des constantes (common/phys/) * +* 3) initialisation des variables temporelles (common * +* /temps/) * +* 4) definition des grilles en rayon et verticale * +* 5) initialisation de c(z,r,t) avec les donnees du * +* fichier unit=1 * +* * +* les donnees sont des valeurs caracterisques de l'atmosphere de * +* TITAN ( voir Lelouch and co ) * +*--------------------------------------------------------------------* + +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/ini/z1,zb1,c0 + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + +* declaration des variables communes +* ---------------------------------- + +cparameter(nz=200,nrad=nqtot) + integer li,lf + real dt,tt + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz), + s rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + real c(nz,nrad,2),c0(nz,nrad) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + +* declaration des variables internes +* ---------------------------------- + + integer nzd + parameter (nzd=254) + integer limsup,liminf,j1,j2 + real zd(nzd),ach4d(nzd),rap + real m + + +* initialisation des constantes physiques +* --------------------------------------- + + pi=4.*atan(1.) + nav=6.022e+23 + rgp=8.3143 + kbz=rgp/nav + rtit=2.8e+6 + g0=1.35 + mch4=16.043e-3 + mar=36.4e-3 + mn2=28.016e-3 + rhol=1e+3 + + +* initialisation des variables temporelles +* ---------------------------------------- + + li=1 + lf=2 + + + + + +* interpolation de xch4,xar et xn2 sur la grille +* ---------------------------------------------- + +* donnees initiales (Lellouch et al,87) +* ------------------------------------- + +c print*,'****** init' + do 1 i=1,168 + zd(i)=(1000.-5*(i-1))*1000. +1 continue + do 2 i=1,78 + zd(168+i)=(160.-2*(i-1))*1000. +2 continue + do 3 i=1,4 + zd(246+i)=(5.-(i-1))*1000. +3 continue + do 4 i=1,4 + zd(250+i)=(1.5-(i-1)*0.5)*1000. +4 continue + + data (ach4d(i),i=1,168)/168*1.5e-2/ + data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2, + 1 1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2, + 2 4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/ + + liminf=0 + limsup=0 + +* interpolation des taux de melange de ch4,ar,n2 +*----------------------------------------------- + + do 20 j1=1,nz + do 21 j2=1,nzd + if( zd(j2).le.z(j1)) goto 22 +21 continue +22 liminf=j2 + if (zd(liminf).eq.z(j1) )then + ach4(j1)=ach4d(liminf) + goto20 + endif + if (j2.ne.1) then + limsup=j2-1 + else + limsup=j2 + endif + + if (limsup.eq.liminf) then + ach4(j1)=ach4(limsup) + else + ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/ + s (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1)) + endif +20 continue + +* rap= aar/an2 cst sur l'altitude + + rap=0.191 + do 23 i=1,nz + an2(i)=(1.-ach4(i))/(1.+rap) + aar(i)=rap*an2(i) +23 continue + + do 24 i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rho(i)=p(i)*m/(rgp*t(i)) +24 continue + + do 34 i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rhob(i)=pb(i)*m/(rgp*tb(i)) +c print*,pb(i),m,rgp,tb(i),rhob(i),rho(i) +34 continue + +* fin d'interpolation des taux de melange +*---------------------------------------- + +c print*,'**** fin init' +540 continue + return + +500 print*,'erreur lecture initialisation de c...erreur=',ii + stop + + end + +*____________________________________________________________________________ + + subroutine pertpro(h,a,l_,pr_) + +***************************************************************************** +* * +* ce programme permet le calcul du terme de production (pr) et de perte (l)* +* pour le phenomene de coagulation * +* dans le a ieme intervalle de rayon a une altitude h * +**************************************************************************** + + + +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + common/coag/k + +* declaration des variables +* -------------------------- + + integer li,lf + real tt,dt +cparameter(nz=200,nrad=nqtot) + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav + real pb(nz),tb(nz),rhob(nz) + real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz) + real vrat,dr(nrad),dv(nrad) + real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),k(nz,nrad,nrad) + real dzb(nz),zb(nz) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,a,x + real*8 pr,ss,s,l + real pr_,l_,vol,del + +* traitement +* ----------- + +* production +*+++++++++++++ + s=0.d0 + ss=0.d0 + pr=0. + + if (a .eq. 1) goto 2 + + b=a-1 + + if (c(h,b,lf) .eq. 0 .and. c(h,b,li) .eq. 0) goto 2 + + do 1 i=1,b + + if(c(h,i,li) .eq. 0 .and. c(h,i,lf) .eq. 0) goto 1 + + if (i .ne. b)del=1. + if (i .eq. b) del=.5 + + s=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,li)*1.d0)+s + ss=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,lf)*1.d0)+ss +c if (a.eq.2) print*,'SS>',v(i),k(h,b,i),c(h,b,lf) +c if (a.eq.2) print*,'SS>',del*v(i)*k(h,b,i)*c(h,b,lf) + + +1 continue + +* calcul du terme de production + + pr=(c(h,b,lf)*s/(vrat-1.)+c(h,b,li)*ss)/v(a) +c if (a.eq.2) print*,'PR>',s,ss,c(h,b,lf),v(a) + +2 continue + + +* perte +*- - - - - + + l=0 + + +* condition limite : pas de perte dans le dernier intervalle + + if (a .eq. nrad) goto 9 + + do 10 x=1,nrad + + if (c(h,x,li) .eq. 0) goto 10 + + if (a .lt. x) vol=1. + if (a .eq. x) vol=.5*vrat/(vrat-1) + if (a .gt. x) vol=v(x)/(v(a)*(vrat-1)) + + l=l+k(h,a,x)*c(h,x,li)*vol*1.d0 + + +10 continue +9 continue + +#ifdef CRAY + l_=l + pr_=pr +#else + l_=sngl(l) + pr_=sngl(pr) +#endif +c l_=sngl(l) +c pr_=sngl(pr) +c if (a.eq.2) print*,'pr_,l_',h,a,pr_,l_ +c if (a.eq.2) print*,'-----------------------' + + + + return + + end + +*_____________________________________________________________________________ + + subroutine production(ihor) +* +*--------------------------------------------------------------------* +* routine calculant le terme de production des molecules organiques * +* composant les aerosols . rini= rayon des aerosols initiaux * +*--------------------------------------------------------------------* +* +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + + integer ndz +cparameter (nrad=nqtot,nz=200,nztop=135) + real zb(nz),z(nz),dz(nz),dzb(nz) + real c(nz,nrad,2) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + integer li,lf + real tt,dt + real fonction,fonction1,fonction2,fonction3,fonction4 + real xlargeur1,xlargeur2,xlargeur3,xlargeur4,xlargeur5 + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zalt0,zy,c0,ctot,prod,rini,rfron + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz) + & ,pb(nz),tb(nz),rhob(nz) + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common /grille/ z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common /con/c + common/part/v,rayon,vrat,dr,dv + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + + common/effets/ xsaison + + + + +c p0=0.3 + p0=1. + do i=1,nz-1 + if (pb(i).lt.p0.and.pb(i+1).gt.p0) zalt0=(z(i)+z(i+1))/2. + enddo + + ctot=3.5e-13*tx ! ATTENTION, ??COHERENT AVEC INITPAR?? + ctot=ctot*xsaison ! + +c zalt0=385.e+3 + zy=20.e+3 + rini=1.3e-9 + rini=rayon(1) + ndz=50 +* + do 10 i=1,nrad + if(rini.lt.rayon(i)) goto 100 +10 continue +100 continue + if (i.eq.1) then + rini=rayon(1) + else + rfron=(rayon(i)+rayon(i-1))/2 + if (rini .lt.rfron) then + rini=rayon(i-1) + i=i-1 + else + rini=rayon(i) + endif + endif +* + c0=ctot/(sqrt(2.*pi)*zy) + c0=c0*3./(4.*pi*rhol*rini**3) +* + do 20 k=nztop,nz +c zmid=(zb(k)+zb(k+1))/2. + prod=0. + do 201 k1=1,ndz + prod=prod+c0*exp(-0.5*(((z(k)+dz(k)/2.-k1*dz(k)/(2.*ndz) + s -zalt0)/zy)**2))*dt/ndz +201 continue + + if (prod .le. 1) prod=0. + c(k,i,lf)=c(k,i,lf)+prod +20 continue + + + return + end + +*-------------------------------------------------------------------* + + + subroutine nuages +* +*-------------------------------------------------------------------- * +* Cete routine transforme les aerosols fractals (i=1..9) en particules * +* spheriques (i=nrad) lors du passage en dessous de la pression de * +* condensation (P=42 Pa) avec une constante de temps de * +* de 10 jours-Titan * +*-------------------------------------------------------------------- * +* +#include "dimensions.h" +#include "microtab.h" + + + integer ndz +cparameter (nrad=nqtot,nz=200,nztop=135) + real zb(nz),z(nz),dz(nz),dzb(nz) + real c(nz,nrad,2) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + integer li,lf + real tt,dt + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zalt0,zy,c0,ctot,prod,rini,rfron + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz) + & ,pb(nz),tb(nz),rhob(nz) + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common /grille/ z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common /con/c + common/part/v,rayon,vrat,dr,dv + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/effets/ xsaison + + xnuage=0.01 + + P_0=900. + P_0=3162. + + do 20 k=nztop,nz + +c transfert i={1...9} vers i=10 au dessous de P_0. + + if (p(k).gt.P_0) then + do 10 i=1,nrad-1 + c(k,nrad,lf)=c(k,nrad,lf)+c(k,i,lf)*xnuage + & *(1.-exp(-dt/1.3824e+06/10.)) + c(k,i,lf)=c(k,i,lf)*exp(-dt/1.3824e+06/10.) + 10 continue + endif + +c transfert i=10 vers i=5 au dessus de P_0 Pascals + + if (p(k).le.P_0) then + c(k,5,lf)=c(k,5,lf)+c(k,nrad,lf) + & *(1.-exp(-dt/1.3824e+06/30.)) + c(k,nrad,lf)=c(k,nrad,lf)*exp(-dt/1.3824e+06/30.) + endif + + 20 continue + + return + end + + +*__________________________________________________________________________ + + subroutine sedif +* +*------------------------------------------------------------------* +* cette routine calcule l'evolution de la fonction de distribution* +* c(z,r,t) pour les phenomenes de sedimentation et de diffusion * +*------------------------------------------------------------------* +* +* +* declaration des blocs communs +*------------------------------ +#include "dimensions.h" +#include "microtab.h" + + common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob + common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + common/grille/z,zb,dz,dzb + common/ctps/li,lf,tt,dt + common/con/c + common/part/v,rayon,vrat,dr,dv + +* declaration des variables communes +* ---------------------------------- + +cparameter(nz=200,nrad=nqtot,nztop=135) + integer li,lf + real tt,dt + real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz) + real pb(nz),tb(nz),rhob(nz) + real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol + real zb(nz),z(nz),dz(nz),dzb(nz) + real c(nz,nrad,2) + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + +* declaration des variables internes +* ---------------------------------- + + real w,w1,dzbX,dc + double precision sigma,theta,hc,l,rap,cmp,wp + double precision fs(nz+1),ft(nz+1) + real as(nz),bs(nz),cs(nz),ds(nz) + double precision asi(nztop:nz),bsi(nztop:nz),csi(nztop:nz) + double precision dsi(nztop:nz),xsol(nztop:nz) + real vitesse,kd + + external dtridgl +* resolution +*------------ + +c print*,'ECHANTILLON.SEDIF.li' +c print*,c(100,1,li),c(100,3,lf),c(100,5,lf) +c print*,c(10,1,li),c(50,3,lf),c(50,5,lf) +c print*,c(10,1,li),c(10,3,lf),c(10,5,lf) + + do 10 k=1,nrad + do 20 j=nztop,nz + + if (j.eq.1) goto 20 + +* calcul de la vitesse corrigee + + dzbX=(dz(j)+dz(j-1))/2. + w=-1*vitesse(j,k,0) + if (kd(j).ne.0.) then + theta=0.5*(w*dzbX/kd(j)+log(rho(j-1)/rho(j))) + if (theta.ne.0) then + sigma=1./dtanh(theta)-1./theta + else + sigma=1. + endif + else + sigma=1. + endif + if(c(j,k,li).eq.0.) then + rap=10. + else + rap=c(j-1,k,li)/c(j,k,li) + if( rap.gt.10.) rap=10. + if( rap.lt.0.1) rap=0.1 + endif + if (rap.gt.0.9 .and. rap.lt.1.1) then + w1=w + else + if(w.ne.0) then + hc=dzbX/dlog(rap) + l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap) + wp=w*1.d0 + cmp=dlog(-wp)+abs(sigma)*dlog(l) + if (cmp.gt.38) then + goto 20 + endif + w1=-dexp(cmp) + + else + w1=0. + endif + endif + +* calcul des flux aux interfaces + + + if (kd(j).ne.0.) then + if (theta.ne.0.) then + ft(j)=(w1+log(rho(j-1)/rho(j))*kd(j)/dzbX)/(dexp(2.* + s theta)-1.) + fs(j)=ft(j)*dexp(2.*theta) + else + ft(j)=kd(j)/dzbX + fs(j)=kd(j)/dzbX + endif + else + if (w1.lt.0.)then + ft(j)=-w1 + fs(j)=0. + else + ft(j)=0. + fs(j)=w1 + endif + endif + +20 continue + +* conditions aux limites pour les flux aux interfaces + + fs(1)=0. + ft(1)=0. + fs(nz+1)=0. + ft(nz+1)=-w1 + +* calcul des coefficients de l'equation discrete + + do 21 j=nztop,nz + as(j)=-dz(j)/dt + bs(j)=-ft(j) + cs(j)=ft(j+1)+fs(j)-dz(j)/dt + ds(j)=-fs(j+1) + + if ( cs(j).gt.0) goto100 +21 continue + +* cas explicite (mu=0) : calcul de la fonction c(z,r,t+1) + + do 22 j=nztop,nz-1 + + if (j.eq.nztop) then + dc=(cs(nztop)*c(nztop,k,li)+ds(nztop) + & *c(nztop+1,k,li))/as(nztop) + c(nztop,k,lf)=dc + + + goto 22 + endif + + dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li)) + s /as(j) + c(j,k,lf)=dc + + +22 continue + + dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz) + c(nz,k,lf)=dc + + + if (nztop.ne.1) then + do 32 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +32 continue + endif + + goto 10 + +100 continue + +* cas implicite (mu=1) : calcul de la fonction c(z,r,t+1) + + do 101 j=nztop,nz + asi(j)=ft(j) + bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt) + csi(j)=fs(j+1) + dsi(j)=-dz(j)/dt*c(j,k,li) +101 continue + +* inversion de la matrice tridiagonale + + nb=nz-nztop+1 + + call dtridgl(nb,asi,bsi,csi,dsi,xsol) + + + do 102 j=nztop,nz + c(j,k,lf)=xsol(j) +102 continue + + if (nztop.ne.1) then + do 110 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +110 continue + endif + + + +10 continue + + return + + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/phyetat0.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/phyetat0.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/phyetat0.F90 (revision 1643) @@ -0,0 +1,372 @@ +! +! $Id $ +! +subroutine phyetat0(fichnom) +! Load initial state for the physics +! and do some resulting initializations + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE phys_state_var_mod + USE iostart + USE geometry_mod, only: latitude_deg,longitude_deg + USE time_phylmdz_mod, only: itau_phy, raz_date + +implicit none +!====================================================================== +! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +! Objet: Lecture de l'etat initial pour la physique +!====================================================================== +#include "netcdf.inc" +#include "dimsoil.h" +#include "clesphys.h" +#include "tabcontrol.h" +!====================================================================== + +character(len=*),intent(in) :: fichnom ! input file name +REAL :: xmin, xmax +LOGICAL :: found +REAL :: tab_cntrl(length) +integer :: i,isoil +CHARACTER(len=2) :: str2 +REAL :: lon_startphy(klon), lat_startphy(klon) + +! les variables globales lues dans le fichier restart + +! open physics initial state file: +call open_startphy(fichnom) + +! +! Lecture des parametres de controle: +! + CALL get_var("controle",tab_cntrl,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + + DO i = 1, length + tabcntr0( i ) = tab_cntrl( i ) + ENDDO + + + dtime = tab_cntrl(1) + radpas = tab_cntrl(2) + chimpas = tab_cntrl(3) + lsinit = tab_cntrl(17) + + itau_phy = tab_cntrl(15) + +! Attention si raz_date est active : +! il faut remettre a zero itau_phy apres phyetat0 ! +! et verifier que lsinit est proche de 0. + IF (raz_date.eq.1) THEN + itau_phy=0 + if ((lsinit.gt.3.).and.(lsinit.lt.357.)) then + PRINT*, 'phyetat0: raz_date=1 and ls different from 0.' + PRINT*, 'When raz_date=1, we reset the initial date' + PRINT*, 'to spring equinox, Ls=0., so the start files' + PRINT*, 'should be within a couple of degrees from Ls=0.' + PRINT*, 'or the circulation will be too far from equilibrium' + CALL abort + endif + ENDIF + +! read latitudes and make a sanity check (because already known from dyn) +call get_field("latitude",lat_startphy,found) +IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort +ENDIF +DO i=1,klon + IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.01) THEN + WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",& + " i=",i," lat_startphy(i)=",lat_startphy(i),& + " latitude_deg(i)=",latitude_deg(i) + CALL abort + ENDIF +ENDDO + +! read longitudes and make a sanity check (because already known from dyn) +call get_field("longitude",lon_startphy,found) +IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort +ENDIF +DO i=1,klon + IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.01) THEN + WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",& + " i=",i," lon_startphy(i)=",lon_startphy(i),& + " longitude_deg(i)=",longitude_deg(i) + CALL abort + ENDIF +ENDDO + +! read in other variables here ... + +! Lecture des temperatures du sol: + + CALL get_field("TS",ftsol(:),found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + PRINT*, 'phyetat0: Le champ est present' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(ftsol(i),xmin) + xmax = MAX(ftsol(i),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + ENDIF + + +! Lecture des temperatures du sol profond: + + DO isoil=1, nsoilmx + IF (isoil.GT.99) THEN + PRINT*, "Trop de couches" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') isoil + CALL get_field('Tsoil'//str2,ftsoil(:,isoil),found) + IF (.not.found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, klon + ftsoil(i,isoil)=ftsol(i) + ENDDO + ENDIF + ENDDO + +! Lecture de albedo au sol: + + CALL get_field("ALBE", falbe,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falbe(i),xmin) + xmax = MAX(falbe(i),xmax) + ENDDO + PRINT*,'Albedo du sol ', xmin, xmax + ENDIF + +! Lecture rayonnement solaire au sol: + + CALL get_field("solsw",solsw,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(solsw(i),xmin) + xmax = MAX(solsw(i),xmax) + ENDDO + PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax + +! Lecture rayonnement IF au sol: + + CALL get_field("sollw",sollw,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(sollw(i),xmin) + xmax = MAX(sollw(i),xmax) + ENDDO + PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax + +! Lecture derive des flux: + + CALL get_field("fder",fder,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(fder(i),xmin) + xmax = MAX(fder(i),xmax) + ENDDO + PRINT*,'Derive des flux fder:', xmin, xmax + +! Lecture du rayonnement net au sol: + + CALL get_field("RADS",radsol,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(radsol(i),xmin) + xmax = MAX(radsol(i),xmax) + ENDDO + PRINT*,'Rayonnement net au sol radsol:', xmin, xmax + +! Lecture de l'orographie sous-maille si ok_orodr: + + if(ok_orodr) then + + CALL get_field("ZMEA",zmea,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zmea(i),xmin) + xmax = MAX(zmea(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax + + CALL get_field("ZSTD",zstd,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zstd(i),xmin) + xmax = MAX(zstd(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax + + CALL get_field("ZSIG",zsig,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zsig(i),xmin) + xmax = MAX(zsig(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax + + CALL get_field("ZGAM",zgam,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zgam(i),xmin) + xmax = MAX(zgam(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax + + CALL get_field("ZTHE",zthe,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zthe(i),xmin) + xmax = MAX(zthe(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax + + CALL get_field("ZPIC",zpic,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zpic(i),xmin) + xmax = MAX(zpic(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax + + CALL get_field("ZVAL",zval,found) + IF (.not.found) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zval(i),xmin) + xmax = MAX(zval(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax + + else + zmea = 0. + zstd = 0. + zsig = 0. + zgam = 0. + zthe = 0. + zpic = 0. + zval = 0. + + endif ! fin test sur ok_orodr + +! Par defaut on cree 2 bandes de methane au pole Nord et au pole Sud +! (entre 75 et 85 degres de latitude) de 2 metres. +! Les poles sont sec ! + resch4(1) = 0. ! pole nord = 1 point + DO i=2,klon + if ((latitude_deg(i).ge.75..and.latitude_deg(i).le.85.).or. & + (latitude_deg(i).ge.-85.and.latitude_deg(i).le.-75.)) then + resch4(i) = 2. + else + resch4(i) = 0. + endif + ENDDO + resch4(klon) = 0. ! pole sud = 1 point + + CALL get_field("RESCH4",resch4,found) + IF (.not.found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Pas de reservoir de methane mais je continue..." + PRINT*, "Pour info, je met 2 metres de methane sur 2 bandes" + PRINT*, "comprises entre 75 et 85 degres de latitude dans " + PRINT*, "chaque hemisphere." + ENDIF + +! Lecture de TANCIEN: + + ancien_ok = .TRUE. + + CALL get_field("TANCIEN",t_ancien,found) + IF (.not.found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ENDIF + +! close file +call close_startphy + +! do some more initializations +call init_iophy_new(latitude_deg,longitude_deg) + +end subroutine phyetat0 Index: trunk/LMDZ.TITAN.old/libf/phytitan/phyredem.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/phyredem.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/phyredem.F90 (revision 1643) @@ -0,0 +1,107 @@ +! +! $Id: $ +! + SUBROUTINE phyredem (fichnom) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE phys_state_var_mod + USE iostart, only : open_restartphy,close_restartphy, & + put_var,put_field + USE geometry_mod, only: longitude_deg, latitude_deg + USE time_phylmdz_mod, only: day_end, annee_ref, itau_phy, raz_date + + implicit none +!====================================================================== +! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +! Objet: Lecture de l'etat initial pour la physique +!====================================================================== +#include "netcdf.inc" +#include "dimsoil.h" +#include "clesphys.h" +#include "tabcontrol.h" +!====================================================================== + +character(len=*),intent(in) :: fichnom +REAL :: tab_cntrl(length) +integer :: isoil +CHARACTER(len=2) :: str2 + + +! open file + + CALL open_restartphy(fichnom) + +! tab_cntrl() contains run parameters + + tab_cntrl(:)=0.0 + + tab_cntrl(1) = dtime + tab_cntrl(2) = radpas + tab_cntrl(3) = chimpas + tab_cntrl(4) = solaire + tab_cntrl(5) = 0 + tab_cntrl(6) = nbapp_rad + tab_cntrl(16)= nbapp_chim + tab_cntrl(17)= lsinit + + IF( cycle_diurne ) tab_cntrl( 7 ) = 1. + IF( soil_model ) tab_cntrl( 8 ) = 1. + IF( ok_orodr ) tab_cntrl(10 ) = 1. + IF( ok_orolf ) tab_cntrl(11 ) = 1. + IF( ok_gw_nonoro ) tab_cntrl(12 ) = 1. + + tab_cntrl(13) = day_end + tab_cntrl(14) = annee_ref + tab_cntrl(15) = itau_phy + + CALL put_var("controle","Parametres de controle",tab_cntrl) + +! coordinates + + CALL put_field("longitude", & + "Longitudes de la grille physique",longitude_deg) + + CALL put_field("latitude", & + "Latitudes de la grille physique",latitude_deg) + +! variables + + CALL put_field("TS","Temperature de surface",ftsol) + + DO isoil=1, nsoilmx + IF (isoil.LE.99) THEN + WRITE(str2,'(i2.2)') isoil + CALL put_field("Tsoil"//str2, & + "Temperature du sol No."//str2,ftsoil(:,isoil)) + ELSE + PRINT*, "Trop de couches" + CALL abort + ENDIF + ENDDO + + CALL put_field("ALBE","albedo de surface",falbe) + CALL put_field("solsw","Rayonnement solaire a la surface",solsw) + CALL put_field("sollw","Rayonnement IR a la surface",sollw) + CALL put_field("fder","Derive de flux",fder) + CALL put_field("RADS","Rayonnement net a la surface",radsol) + CALL put_field("ZMEA","zmea Orographie sous-maille",zmea) + CALL put_field("ZSTD","zstd Orographie sous-maille",zstd) + CALL put_field("ZSIG","zsig Orographie sous-maille",zsig) + CALL put_field("ZGAM","zgam Orographie sous-maille",zgam) + CALL put_field("ZTHE","zthe Orographie sous-maille",zthe) + CALL put_field("ZPIC","zpic Orographie sous-maille",zpic) + CALL put_field("ZVAL","zval Orographie sous-maille",zval) + + CALL put_field("RESCH4","Reservoir CH4 a la surface",resch4) + + CALL put_field("TANCIEN","T Previous iteration",t_ancien) + +! close file + + CALL close_restartphy +!$OMP BARRIER + + END SUBROUTINE phyredem Index: trunk/LMDZ.TITAN.old/libf/phytitan/phys_state_var_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/phys_state_var_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/phys_state_var_mod.F90 (revision 1643) @@ -0,0 +1,172 @@ +! +! $Id: phys_state_var_mod.F90 1670 2012-10-17 08:42:04Z idelkadi $ +! + MODULE phys_state_var_mod +! Variables sauvegardees pour le startphy.nc +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + USE dimphy +! INTEGER, SAVE :: radpas +!!$OMP THREADPRIVATE(radpas) +! REAL, SAVE :: dtime +!!$OMP THREADPRIVATE(dtime) + + REAL, ALLOCATABLE, SAVE :: ftsol(:) +!$OMP THREADPRIVATE(ftsol) + REAL, ALLOCATABLE, SAVE :: ftsoil(:,:) +!$OMP THREADPRIVATE(ftsoil) + REAL, ALLOCATABLE, SAVE :: falbe(:) +!$OMP THREADPRIVATE(falbe) + +!clesphy0 param physiq +! +! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +! + REAL, ALLOCATABLE, SAVE :: zmea(:), zstd(:), zsig(:), zgam(:) +!$OMP THREADPRIVATE(zmea, zstd, zsig, zgam) + REAL, ALLOCATABLE, SAVE :: zthe(:), zpic(:), zval(:) +!$OMP THREADPRIVATE(zthe, zpic, zval) +! REAL tabcntr0(100) + REAL, ALLOCATABLE, SAVE :: rugoro(:) +!$OMP THREADPRIVATE(rugoro) + REAL, ALLOCATABLE, SAVE :: t_ancien(:,:), q_ancien(:,:) +!$OMP THREADPRIVATE(t_ancien, q_ancien) + REAL, ALLOCATABLE, SAVE :: u_ancien(:,:), v_ancien(:,:) +!$OMP THREADPRIVATE(u_ancien, v_ancien) + LOGICAL, SAVE :: ancien_ok +!$OMP THREADPRIVATE(ancien_ok) +! pressure level + REAL,ALLOCATABLE,SAVE :: zuthe(:),zvthe(:) +!$OMP THREADPRIVATE(zuthe,zvthe) +! +! heat : chauffage solaire +! heat0: chauffage solaire ciel clair +! cool : refroidissement infrarouge +! cool0 : refroidissement infrarouge ciel clair +! sollwdown : downward LW flux at surface +! sollwdownclr : downward CS LW flux at surface +! toplwdown : downward CS LW flux at TOA +! toplwdownclr : downward CS LW flux at TOA +! swnet,swdn,lwdn: + downward +! lwnet,swup,lwup: + upward + REAL,ALLOCATABLE,SAVE :: swnet(:,:),swup(:,:),swdn(:,:) +!$OMP THREADPRIVATE(swnet,swup,swdn) + REAL,ALLOCATABLE,SAVE :: lwnet(:,:),lwup(:,:),lwdn(:,:) +!$OMP THREADPRIVATE(lwnet,lwup,lwdn) + REAL,ALLOCATABLE,SAVE :: heat(:,:) +!$OMP THREADPRIVATE(heat) + REAL,ALLOCATABLE,SAVE :: heat0(:,:) +!$OMP THREADPRIVATE(heat0) + REAL,ALLOCATABLE,SAVE :: cool(:,:) +!$OMP THREADPRIVATE(cool) + REAL,ALLOCATABLE,SAVE :: cool0(:,:) +!$OMP THREADPRIVATE(cool0) + REAL,ALLOCATABLE,SAVE :: dtrad(:,:) +!$OMP THREADPRIVATE(dtrad) + REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:) +!$OMP THREADPRIVATE(topsw,toplw) + REAL, ALLOCATABLE, SAVE :: solsw(:), sollw(:) +!$OMP THREADPRIVATE(solsw, sollw) + REAL, ALLOCATABLE, SAVE :: radsol(:) +!$OMP THREADPRIVATE(radsol) + REAL,ALLOCATABLE,SAVE :: sollwdown(:) +!$OMP THREADPRIVATE(sollwdown) + REAL,ALLOCATABLE,SAVE :: sollwdownclr(:) +!$OMP THREADPRIVATE(sollwdownclr) + REAL,ALLOCATABLE,SAVE :: toplwdown(:) +!$OMP THREADPRIVATE(toplwdown) + REAL,ALLOCATABLE,SAVE :: toplwdownclr(:) +!$OMP THREADPRIVATE(toplwdownclr) + REAL,ALLOCATABLE,SAVE :: topsw0(:),toplw0(:),solsw0(:),sollw0(:) +!$OMP THREADPRIVATE(topsw0,toplw0,solsw0,sollw0) + REAL,save,allocatable :: dlw(:) ! derivee infra rouge + REAL,save,allocatable :: fder(:) ! Derive de flux (sensible et latente) +!$OMP THREADPRIVATE(dlw,fder) + +! +! Parametres pour le cycle du methane: +! + REAL,save,allocatable :: resch4(:) ! surface reservoir CH4 +!$OMP THREADPRIVATE(resch4) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_state_var_init + +IMPLICIT NONE +#include "dimsoil.h" + + ALLOCATE(ftsol(klon)) ! temperature de surface + ALLOCATE(ftsoil(klon,nsoilmx)) ! temperature dans le sol + ALLOCATE(falbe(klon)) ! albedo + +! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +! +!zmea(:) ! orographie moyenne +!zstd(:) ! deviation standard de l'OESM +!zsig(:) ! pente de l'OESM +!zgam(:) ! anisotropie de l'OESM +!zthe(:) ! orientation de l'OESM +!zpic(:) ! Maximum de l'OESM +!zval(:) ! Minimum de l'OESM +!rugoro(:) ! longueur de rugosite de l'OESM + ALLOCATE(zmea(klon), zstd(klon), zsig(klon), zgam(klon)) + ALLOCATE(zthe(klon), zpic(klon), zval(klon)) + ALLOCATE(rugoro(klon)) + + ALLOCATE(t_ancien(klon,klev), q_ancien(klon,klev)) + ALLOCATE(u_ancien(klon,klev), v_ancien(klon,klev)) + + ALLOCATE(zuthe(klon),zvthe(klon)) +! + ALLOCATE(swnet(klon,klev+1), lwnet(klon,klev+1)) + ALLOCATE(swup(klon,klev+1), lwup(klon,klev+1)) + ALLOCATE(swdn(klon,klev+1), lwdn(klon,klev+1)) + ALLOCATE(heat(klon,klev), heat0(klon,klev)) + ALLOCATE(cool(klon,klev), cool0(klon,klev)) + ALLOCATE(dtrad(klon,klev)) + ALLOCATE(topsw(klon), toplw(klon)) + ALLOCATE(solsw(klon), sollw(klon)) + ALLOCATE(radsol(klon)) ! bilan radiatif au sol calcule par code radiatif + ALLOCATE(sollwdown(klon), sollwdownclr(klon)) + ALLOCATE(toplwdown(klon), toplwdownclr(klon)) + ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon)) + ALLOCATE(dlw(klon), fder(klon)) + + ALLOCATE(resch4(klon)) + +END SUBROUTINE phys_state_var_init + +!====================================================================== +SUBROUTINE phys_state_var_end + +IMPLICIT NONE + + deallocate(ftsol, ftsoil, falbe) + deallocate(zmea, zstd, zsig, zgam) + deallocate(zthe, zpic, zval) + deallocate(rugoro, t_ancien, q_ancien) + deallocate( u_ancien, v_ancien) + deallocate(zuthe, zvthe) + deallocate(swnet, lwnet) + deallocate(swup, lwup) + deallocate(swdn, lwdn) + deallocate(heat, heat0) + deallocate(cool, cool0) + deallocate(dtrad) + deallocate(solsw, sollw, radsol) + deallocate(topsw, toplw) + deallocate(sollwdown, sollwdownclr) + deallocate(toplwdown, toplwdownclr) + deallocate(topsw0,toplw0,solsw0,sollw0) + deallocate(dlw, fder) + + deallocate(resch4) + +END SUBROUTINE phys_state_var_end + + END MODULE phys_state_var_mod Index: trunk/LMDZ.TITAN.old/libf/phytitan/physiq_mod.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/physiq_mod.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/physiq_mod.F (revision 1643) @@ -0,0 +1,1637 @@ +! +! $Id: $ +! + MODULE physiq_mod + + IMPLICIT NONE + + CONTAINS + + SUBROUTINE physiq (nlon,nlev,nqmax, + . debut,lafin,rjourvrai,gmtime,pdtphys, + . paprs,pplay,ppk,pphi,pphis,presnivs, + . u,v,t,qx, + . flxmw, + . d_u, d_v, d_t, d_qx, d_ps) + +c====================================================================== +c +c Modifications pour la physique de Titan +c S. Lebonnois (LMD/CNRS) Juin 2013: Parallelisation +c +c --------------------------------------------------------------------- +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c +c Objet: Moniteur general de la physique du modele +cAA Modifications quant aux traceurs : +cAA - uniformisation des parametrisations ds phytrac +cAA - stockage des moyennes des champs necessaires +cAA en mode traceur off-line +c modif ( P. Le Van , 12/10/98 ) +c +c Arguments: +c +c nlon----input-I-nombre de points horizontaux +c nlev----input-I-nombre de couches verticales +c nqmax---input-I-nombre de traceurs +c debut---input-L-variable logique indiquant le premier passage +c lafin---input-L-variable logique indiquant le dernier passage +c rjour---input-R-numero du jour de l'experience +c gmtime--input-R-temps universel dans la journee (0 a RDAY s) +c pdtphys-input-R-pas d'integration pour la physique (seconde) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c ppk ---input-R-fonction d'Exner au milieu de couche +c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) +c pphis---input-R-geopotentiel du sol +c presnivs-input_R_pressions approximat. des milieux couches ( en PA) +c u-------input-R-vitesse dans la direction X (de O a E) en m/s +c v-------input-R-vitesse Y (de S a N) en m/s +c t-------input-R-temperature (K) +c qx------input-R-mass mixing ratio traceurs (kg/kg) +c d_t_dyn-input-R-tendance dynamique pour "t" (K/s) +c flxmw---input-R-flux de masse vertical en kg/s +c +c d_u-----output-R-tendance physique de "u" (m/s/s) +c d_v-----output-R-tendance physique de "v" (m/s/s) +c d_t-----output-R-tendance physique de "t" (K/s) +c d_qx----output-R-tendance physique de "qx" (kg/kg/s) +c d_ps----output-R-tendance physique de la pression au sol +c====================================================================== + USE ioipsl +! USE histcom ! not needed; histcom is included in ioipsl + USE infotrac_phy, ONLY: iflag_trac, tname, ttext + use dimphy + USE geometry_mod, ONLY: longitude, latitude, ! in radians + & longitude_deg, latitude_deg, ! in degrees + & cell_area, dx, dy + use cpdet_phy_mod, only: cpdet, t2tpot + USE mod_phys_lmdz_para, only : is_parallel,jj_nb, + & is_north_pole_phy, + & is_south_pole_phy + USE phys_state_var_mod ! Variables sauvegardees de la physique + USE iophy + USE common_mod, only: rmcbar,xfbar,ncount, + & flxesp_i,tau_drop,tau_aer,solesp,precip, + & evapch4,occcld_m,occcld,satch4,satc2h6,satc2h2,rmcloud, + & TauHID,TauHVD,TauGID,TauGVD,TauCID,TauCVD,NSPECV,NSPECI, + & common_init + + USE moyzon_mod + USE write_field_phy + USE time_phylmdz_mod, only: itau_phy,day_ref,annee_ref,nday + USE logic_mod, only: moyzon_ch,moyzon_mu + USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev + IMPLICIT none +c====================================================================== +c CLEFS CPP POUR LES IO +c ===================== +#define histday +#define histmth +#define histins +c====================================================================== +#include "dimensions.h" + integer jjmp1 + parameter (jjmp1=jjm+1-1/jjm) +#include "dimsoil.h" +#include "clesphys.h" +#include "iniprint.h" +#include "tabcontrol.h" +#include "comorbit.h" +#include "microtab.h" +#include "itemps.h" +c====================================================================== + LOGICAL ok_journe ! sortir le fichier journalier + save ok_journe +c PARAMETER (ok_journe=.true.) +c + LOGICAL ok_mensuel ! sortir le fichier mensuel + save ok_mensuel +c PARAMETER (ok_mensuel=.true.) +c + LOGICAL ok_instan ! sortir le fichier instantane + save ok_instan +c PARAMETER (ok_instan=.true.) +c +c====================================================================== +c +c Variables argument: +c + INTEGER nlon + INTEGER nlev + INTEGER nqmax + REAL rjourvrai + REAL gmtime + REAL pdtphys + LOGICAL debut, lafin + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + REAL pphis(klon) + REAL presnivs(klev) + +! ADAPTATION GCM POUR CP(T) + REAL ppk(klon,klev) + + REAL u(klon,klev) + REAL v(klon,klev) + REAL t(klon,klev) + REAL qx(klon,klev,nqmax) + + REAL d_u_dyn(klon,klev) + REAL d_t_dyn(klon,klev) + + REAL flxmw(klon,klev) + + REAL d_u(klon,klev) + REAL d_v(klon,klev) + REAL d_t(klon,klev) + REAL d_qx(klon,klev,nqmax) + REAL d_ps(klon) + +c Variables propres a la physique +c + REAL,save,allocatable :: rlev(:,:) ! altitude a chaque niveau (interface inferieure de la couche) + INTEGER,save :: itap ! compteur pour la physique + REAL delp(klon,klev) ! epaisseur d'une couche + REAL omega(klon,klev) + + INTEGER igwd,idx(klon),itest(klon) +c +c Diagnostiques 2D de drag_noro, lift_noro et gw_nonoro + + REAL zulow(klon),zvlow(klon) + REAL zustrdr(klon), zvstrdr(klon) + REAL zustrli(klon), zvstrli(klon) + REAL zustrhi(klon), zvstrhi(klon) + +c Pour calcul GW drag oro et nonoro: CALCUL de N2: + real zdzlev(klon,klev) + real ztlev(klon,klev),zpklev(klon,klev) + real ztetalay(klon,klev),ztetalev(klon,klev) + real zdtetalev(klon,klev) + real zn2(klon,klev) ! BV^2 at plev + +c Pour les bilans de moment angulaire, + integer bilansmc +c Pour le transport de ballons + integer ballons +c j'ai aussi besoin +c du stress de couche limite a la surface: + + REAL zustrcl(klon),zvstrcl(klon) + +c et du stress total c de la physique: + + REAL zustrph(klon),zvstrph(klon) + +c Variables locales: +c + REAL cdragh(klon) ! drag coefficient pour T and Q + REAL cdragm(klon) ! drag coefficient pour vent +c +cAA Pour TRACEURS +cAA + REAL,save,allocatable :: source(:,:) + integer nmicro + save nmicro + character*8 nom + REAL qaer(klon,klev,nqmax) + + REAL ycoefh(klon,klev) ! coef d'echange pour phytrac + REAL yu1(klon) ! vents dans la premiere couche U + REAL yv1(klon) ! vents dans la premiere couche V + + REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee + REAL ve(klon) ! integr. verticale du transport meri. de l'energie + REAL vq(klon) ! integr. verticale du transport meri. de l'eau + REAL ue(klon) ! integr. verticale du transport zonal de l'energie + REAL uq(klon) ! integr. verticale du transport zonal de l'eau +c + +c====================================================================== +c +c Declaration des procedures appelees +c + EXTERNAL ajsec ! ajustement sec + EXTERNAL clmain ! couche limite + EXTERNAL hgardfou ! verifier les temperatures + EXTERNAL orbite ! calculer l'orbite + EXTERNAL phyetat0 ! lire l'etat initial de la physique + EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique + EXTERNAL radlwsw ! rayonnements solaire et infrarouge + EXTERNAL suphec ! initialiser certaines constantes +c EXTERNAL transp ! transport total de l'eau et de l'energie + EXTERNAL abort_gcm + EXTERNAL printflag + EXTERNAL zenang + EXTERNAL diagetpq + EXTERNAL conf_phys + EXTERNAL diagphy + EXTERNAL mucorr + EXTERNAL phytrac +c +c Variables locales +c +CXXX PB + REAL fluxt(klon,klev) ! flux turbulent de chaleur + REAL fluxu(klon,klev) ! flux turbulent de vitesse u + REAL fluxv(klon,klev) ! flux turbulent de vitesse v +c + REAL flux_dyn(klon,klev) ! flux de chaleur produit par la dynamique + REAL flux_ajs(klon,klev) ! flux de chaleur ajustement sec + REAL flux_ec(klon,klev) ! flux de chaleur Ec +c + REAL dtimerad + INTEGER itaprad + SAVE itaprad,dtimerad + REAL zdtime +c +c CHIMIE + + REAL dtimechim + INTEGER itapchim,appel_chim + SAVE itapchim,dtimechim + +c ORBITE + + REAL dist, rmu0(klon), fract(klon), pdecli + REAL rmu0bar(klon), fractbar(klon) + REAL zday + REAL zls,zlsdeg,zlsm1 + save zlsm1 +c + INTEGER i, k, iq, ig, j, ll, l +c + REAL zphi(klon,klev) + REAL zzlev(klon,klev+1),zzlay(klon,klev),z1,z2 +c +c Variables du changement +c +c ajs: ajustement sec +c vdf: couche limite (Vertical DiFfusion) +c mph: microphysique +c kim: chimie + REAL d_t_ajs(klon,klev), d_tr_ajs(klon,klev,nqmax) + REAL d_u_ajs(klon,klev), d_v_ajs(klon,klev) +c + REAL d_ts(klon) +c + REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev) + REAL d_t_vdf(klon,klev), d_tr_vdf(klon,klev,nqmax) +c + REAL d_tr_mph(klon,klev,nqmax),d_tr_kim(klon,klev,nqmax) + +CMOD LOTT: Tendances Orography Sous-maille + REAL d_u_oro(klon,klev), d_v_oro(klon,klev) + REAL d_t_oro(klon,klev) + REAL d_u_lif(klon,klev), d_v_lif(klon,klev) + REAL d_t_lif(klon,klev) +C Tendances Ondes de G non oro (runs strato). + REAL d_u_hin(klon,klev), d_v_hin(klon,klev) + REAL d_t_hin(klon,klev) + +c +c Variables liees a l'ecriture de la bande histoire physique +c + INTEGER ecrit_mth + SAVE ecrit_mth ! frequence d'ecriture (fichier mensuel) +c + INTEGER ecrit_day + SAVE ecrit_day ! frequence d'ecriture (fichier journalier) +c + INTEGER ecrit_ins + SAVE ecrit_ins ! frequence d'ecriture (fichier instantane) +c + integer itau_w ! pas de temps ecriture = itap + itau_phy + +c Variables locales pour effectuer les appels en serie +c + REAL t_seri(klon,klev) + REAL u_seri(klon,klev), v_seri(klon,klev) +c + REAL tr_seri(klon,klev,nqmax) + REAL d_tr(klon,klev,nqmax) +c +c pour ioipsl + INTEGER nid_day, nid_mth, nid_ins + SAVE nid_day, nid_mth, nid_ins + INTEGER nhori, nvert, idayref + REAL zsto, zout, zsto1, zsto2, zero + parameter (zero=0.0e0) + real zjulian + save zjulian + REAL tmpout(klon,klev) ! pour sorties + + CHARACTER*1 str1 + CHARACTER*2 str2 + character*20 modname + character*80 abort_message + logical ok_sync + + character*30 nom_fichier + character*10 varname + character*40 vartitle + character*20 varunits +C Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy + REAL zero_v(klon),zero_v2(klon,klev) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/2/ + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil +c+jld ec_conser + REAL d_t_ec(klon,klev) ! tendance du a la conversion Ec -> E thermique +c-jld ec_conser + +c TEST VENUS... + REAL mang(klon,klev) ! moment cinetique + REAL mangtot ! moment cinetique total + +c Temporaire avant de trouver mieux : +c Recuperation des TAU du TR + REAL t_tauhvd(klon,klev),t_khvd(klon,klev) + REAL t_tcld(klon,klev),t_kcld(klon,klev) + REAL t_kcvd(klon,klev) + + REAL ch4(klon,jjm+1),dch4(jjm+1) + INTEGER ig0 + integer ich4 + common/ch4ind/ich4 + +c flux de chaleur latente d'evaporation CH4 + REAL fclat(klon) +c reservoir de surface + REAL,save,allocatable :: reservoir(:) + +c cell_area for outputs in hist* + REAL cell_area_out(klon) + +c Declaration des constantes et des fonctions thermodynamiques +c +#include "YOMCST.h" + +c====================================================================== +c INITIALISATIONS +c================ + + modname = 'physiq' + ok_sync=.TRUE. + + bilansmc = 0 + ballons = 0 +! NE FONCTIONNENT PAS ENCORE EN PARALLELE !!! + if (is_parallel) then + bilansmc = 0 + ballons = 0 + endif + + IF (if_ebil.ge.1) THEN + DO i=1,klon + zero_v(i)=0. + END DO + DO i=1,klon + DO j=1,klev + zero_v2(i,j)=0. + END DO + END DO + END IF + +c PREMIER APPEL SEULEMENT +c======================== + IF (debut) THEN + allocate(rlev(klon,klevp1)) + allocate(source(klon,nqmax)) + allocate(reservoir(klon)) + + CALL suphec ! initialiser constantes et parametres phys. + + IF (if_ebil.ge.1) d_h_vcol_phy=0. +c +c appel a la lecture du physiq.def +c + call conf_phys(ok_mensuel,ok_journe, + . ok_instan, + . if_ebil) + + call phys_state_var_init + call common_init +c +c Initialiser les compteurs: +c + itap = 0 + itaprad = 0 + itapchim = 1 + +c init rnuabar + ncount(:,:) = 0 + rmcbar = 0. + xfbar = 0. + +c +c Lecture startphy.nc : +c + CALL phyetat0 ("startphy.nc") + +c dtime est defini dans tabcontrol.h et lu dans startphy +c pdtphys est calcule a partir des nouvelles conditions: +c Reinitialisation du pas de temps physique quand changement + IF (ABS(dtime-pdtphys).GT.0.001) THEN + WRITE(lunout,*) 'Pas physique a change',dtime, + . pdtphys +c abort_message='Pas physique n est pas correct ' +c call abort_gcm(modname,abort_message,1) +c---------------- +c pour initialiser convenablement le time_counter, il faut tenir compte +c du changement de dtime en changeant itau_phy (point de depart) + itau_phy = NINT(itau_phy*dtime/pdtphys) +c---------------- + dtime=pdtphys + ENDIF + + radpas = NINT( RDAY/pdtphys/nbapp_rad) + chimpas = radpas*nbapp_rad/nbapp_chim + + CALL printflag( ok_mensuel,ok_journe,ok_instan ) +c +c Initialiser les pas de temps: +c + dtimerad = dtime*REAL(radpas) ! pas de temps du rayonnement (s) +c PRINT*,'dtimerad,dtime,radpas',dtimerad,dtime,radpas + + dtimechim = dtime*REAL(chimpas) ! pas de temps de la chimie (s) +c PRINT*,'dtimechim,dtime,chimpas',dtimechim,dtime,chimpas + + +c INITIALISATION ORBITE + + CALL iniorbit(aphelie,periheli,year_day,peri_day,obliquit) + +c--------- +c FLOTT + IF (ok_orodr) THEN + DO i=1,klon + rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ENDDO + CALL SUGWD(klon,klev,paprs,pplay) + DO i=1,klon + zuthe(i)=0. + zvthe(i)=0. + if(zstd(i).gt.10.)then + zuthe(i)=(1.-zgam(i))*cos(zthe(i)) + zvthe(i)=(1.-zgam(i))*sin(zthe(i)) + endif + ENDDO + ENDIF + + if (bilansmc.eq.1) then +C OUVERTURE D'UN FICHIER FORMATTE POUR STOCKER LES COMPOSANTES +C DU BILAN DE MOMENT ANGULAIRE. + open(27,file='aaam_bud.out',form='formatted') + open(28,file='fields_2d.out',form='formatted') + write(*,*)'Ouverture de aaam_bud.out (FL Vous parle)' + write(*,*)'Ouverture de fields_2d.out (FL Vous parle)' + endif !bilansmc + +c--------------SLEBONNOIS +C OUVERTURE DES FICHIERS FORMATTES CONTENANT LES POSITIONS ET VITESSES +C DES BALLONS + if (ballons.eq.1) then + open(30,file='ballons-lat.out',form='formatted') + open(31,file='ballons-lon.out',form='formatted') + open(32,file='ballons-u.out',form='formatted') + open(33,file='ballons-v.out',form='formatted') + open(34,file='ballons-alt.out',form='formatted') + write(*,*)'Ouverture des ballons*.out' + endif !ballons +c------------- + +c--------- +C TRACEURS +C source dans couche limite + source = 0.0 ! pas de source, pour l'instant +C +c Si microphysique offline, pas besoin d'avoir de traceurs microphysiques +c car on lit les profils verticaux des qaer dans une look-up table pour +c le rayonnement. + +c calcul de nmicro +c !!!! Les traceurs microphysiques doivent etre toujours en premiers!! + + nmicro = 0 + do iq=1,nqmax + nom = tname(iq) +c print*,iq,"nom=",nom,"tname=",tname(iq) + print*,iq,"nom=",nom + if (nom(1:1).eq."q") then + nmicro = nmicro+1 + endif + enddo + print*,"nmicro=",nmicro + +c -------------- +c Verifications: +c -------------- + IF ((nmicro.eq.0).and.(microfi.eq.1)) THEN + abort_message="MICROPHYSIQUE ONLINE, MAIS NMICRO=0..." + call abort_gcm(modname,abort_message,1) + ENDIF + IF (microfi.lt.1.and.clouds.eq.1) THEN + write(lunout,*)"microfi.lt.1.and.clouds.eq.1" + abort_message = + & "Impossible de faire des nuages sans microphysique..." + call abort_gcm(modname,abort_message,1) + ENDIF + IF (nlon .NE. klon) THEN + WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, + . klon + abort_message='nlon et klon ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF + IF (nlev .NE. klev) THEN + WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, + . klev + abort_message='nlev et klev ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF (((moyzon_mu).and.(microfi.ne.1)).or. + . ((.not.moyzon_mu).and.(microfi.eq.1))) THEN + abort_message="Microphysic 2D and moyzon_mu not compatible" + write(lunout,*) "moyzon_mu=",moyzon_mu + write(lunout,*) "microfi=",microfi + call abort_gcm(modname,abort_message,1) + ENDIF + IF (((moyzon_ch).and.(.not.chimi)).or. + . ((.not.moyzon_ch).and.(chimi))) THEN + abort_message="Chemistry and moyzon_ch not compatible" + write(lunout,*) "moyzon_ch=",moyzon_ch + write(lunout,*) "chimi=",chimi + call abort_gcm(modname,abort_message,1) + ENDIF + + IF (dtime*REAL(radpas).GT.(RDAY*0.25).AND.cycle_diurne) + $ THEN + WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' + WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" + abort_message='Nbre d appels au rayonnement insuffisant' + call abort_gcm(modname,abort_message,1) + ENDIF +c + WRITE(lunout,*)"Clef pour la convection seche, iflag_ajs=", + . iflag_ajs +c + ecrit_mth = NINT(RDAY/dtime) *nday ! tous les nday jours + IF (ok_mensuel) THEN + WRITE(lunout,*)'La frequence de sortie mensuelle est de ', + . ecrit_mth + ENDIF + + ecrit_day = NINT(RDAY/dtime *1.0) ! tous les jours + IF (ok_journe) THEN + WRITE(lunout,*)'La frequence de sortie journaliere est de ', + . ecrit_day + ENDIF + + ecrit_ins = NINT(RDAY/dtime*ecriphy) ! Fraction de jour reglable + IF (ok_instan) THEN + WRITE(lunout,*)'La frequence de sortie instant. est de ', + . ecrit_ins + ENDIF + +c Initialisation des sorties +c=========================== + +#ifdef CPP_IOIPSL + +#ifdef histday +#include "ini_histday.h" +#endif + +#ifdef histmth +#include "ini_histmth.h" +#endif + +#ifdef histins +#include "ini_histins.h" +#endif + +#endif + +c +c Initialiser les valeurs de u pour calculs tendances +c (pour T, c'est fait dans phyetat0) +c + DO k = 1, klev + DO i = 1, klon + u_ancien(i,k) = u(i,k) + ENDDO + ENDDO + + ENDIF ! debut +c==================================================================== +c====================================================================== + +c Creer un reservoir de surface infini +c + reservoir(:) = 2. + +c Mettre a zero des variables de sortie (pour securite) +c + DO i = 1, klon + d_ps(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + ENDDO + ENDDO + DO iq = 1, nqmax + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = 0.0 + ENDDO + ENDDO + ENDDO +c +c Ne pas affecter les valeurs entrees de u, v, h, et q +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t(i,k) + u_seri(i,k) = u(i,k) + v_seri(i,k) = v(i,k) + ENDDO + ENDDO + DO iq = 1, nqmax + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,iq) = qx(i,k,iq) + ENDDO + ENDDO + ENDDO +C + DO i = 1, klon + ztsol(i) = ftsol(i) + ENDDO +C + IF (if_ebil.ge.1) THEN + ztit='after dynamic' + CALL diagetpq(cell_area,ztit,ip_ebil,1,1,dtime + e , t_seri,zero_v2,zero_v2,zero_v2,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + call diagphy(cell_area,ztit,ip_ebil + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol+d_h_vcol_phy, d_qt, 0. + s , fs_bound, fq_bound ) + END IF + +c==================================================================== +c Diagnostiquer la tendance dynamique +c + IF (ancien_ok) THEN + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime + d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime + ENDDO + ENDDO + +! ADAPTATION GCM POUR CP(T) + do i=1,klon + flux_dyn(i,1) = 0.0 + do j=2,klev + flux_dyn(i,j) = flux_dyn(i,j-1) + . +cpdet(t_seri(i,j-1))/RG*d_t_dyn(i,j-1)*(paprs(i,j-1)-paprs(i,j)) + enddo + enddo + + ELSE + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = 0.0 + d_t_dyn(i,k) = 0.0 + ENDDO + ENDDO + ancien_ok = .TRUE. + ENDIF +c==================================================================== +c +c Calcule de vitesse verticale a partir de flux de masse verticale + DO k = 1, klev + DO i = 1, klon + omega(i,k) = RG*flxmw(i,k) / cell_area(i) + END DO + END DO + +c Ajouter le geopotentiel du sol: +c + DO k = 1, klev + DO i = 1, klon + zphi(i,k) = pphi(i,k) + pphis(i) + ENDDO + ENDDO + +c call WriteField_phy('physiq_pphi',pphi,klev) +c call WriteField_phy('physiq_pphis',pphis,1) + +c calcul du geopotentiel aux niveaux intercouches +c ponderation des altitudes au niveau des couches en dp/p + + DO l=1,klev + DO i=1,klon +c zzlay(i,l)=zphi(i,l)/RG +c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE: + zzlay(i,l)=RG*RA*RA/(RG*RA-zphi(i,l))-RA + ENDDO + ENDDO + DO i=1,klon +c zzlev(i,1)=0. +c CORRECTION 13/01/2011 +c (correspond a la position de la surface en ce point vs RA) + zzlev(i,1)=pphis(i)/RG + ENDDO + DO l=2,klev + DO i=1,klon + z1=(pplay(i,l-1)+paprs(i,l))/(pplay(i,l-1)-paprs(i,l)) + z2=(paprs(i,l) +pplay(i,l))/(paprs(i,l) -pplay(i,l)) + zzlev(i,l)=(z1*zzlay(i,l-1)+z2*zzlay(i,l))/(z1+z2) + ENDDO + ENDDO + DO i=1,klon + zzlev(i,klev+1)=zzlay(i,klev)+(zzlay(i,klev)-zzlev(i,klev)) + ENDDO + +! zonal averages needed + if (moyzon_ch.or.moyzon_mu) then + +c zzlaybar(1,:)=(zphibar(1,:)+zphisbar(1))/RG +c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE: + zzlaybar(1,:)=RG*RA*RA/(RG*RA-(zphibar(1,:)+zphisbar(1)))-RA + zzlevbar(1,1)=zphisbar(1)/RG + DO l=2,klev + z1=(zplaybar(1,l-1)+zplevbar(1,l))/ + . (zplevbar(1,l-1)-zplevbar(1,l)) + z2=(zplevbar(1,l) +zplaybar(1,l))/ + . (zplevbar(1,l) -zplaybar(1,l)) + zzlevbar(1,l)=(z1*zzlaybar(1,l-1)+z2*zzlaybar(1,l))/(z1+z2) + ENDDO + zzlevbar(1,klev+1)=zzlaybar(1,klev)+ + . (zzlaybar(1,klev)-zzlevbar(1,klev)) + + DO i=2,klon + if (latitude(i).ne.latitude(i-1)) then + DO l=1,klev +c zzlaybar(i,l)=(zphibar(i,l)+zphisbar(i))/RG +c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE: + zzlaybar(i,l)=RG*RA*RA/(RG*RA-(zphibar(i,l)+zphisbar(i)))-RA + ENDDO + zzlevbar(i,1)=zphisbar(i)/RG + DO l=2,klev + z1=(zplaybar(i,l-1)+zplevbar(i,l))/ + . (zplevbar(i,l-1)-zplevbar(i,l)) + z2=(zplevbar(i,l) +zplaybar(i,l))/ + . (zplevbar(i,l) -zplaybar(i,l)) + zzlevbar(i,l)=(z1*zzlaybar(i,l-1)+z2*zzlaybar(i,l))/(z1+z2) + ENDDO + zzlevbar(i,klev+1)=zzlaybar(i,klev)+ + . (zzlaybar(i,klev)-zzlevbar(i,klev)) + else + zzlaybar(i,:)=zzlaybar(i-1,:) + zzlevbar(i,:)=zzlevbar(i-1,:) + endif + ENDDO + + endif ! moyzon + +c call WriteField_phy('physiq_zphi',zphi,klev) +c call WriteField_phy('physiq_zzlay',zzlay,klev) +c call WriteField_phy('physiq_zzlev',zzlev,klev+1) +c- - - - - - - - - - - - - - - - +c DIAGNOSTIQUE GRILLE VERTICALE +c- - - - - - - - - - - - - - - - +c print*,"DIAGNOSTIQUE GRILLE VERTICALE" +c i=klon/2 +c print*,"Niveau Pression Altitude (lev puis lay)" +c do l=1,klev +c print*,l,paprs(i,l),zzlev(i,l) +c print*,l,pplay(i,l),zzlay(i,l) +c enddo +c print*,klev+1,paprs(i,klev+1),zzlev(i,klev+1) +c stop + +c==================================================================== +c +c Verifier les temperatures +c + CALL hgardfou(t_seri,ftsol,'debutphy') +c==================================================================== +c +c Incrementer le compteur de la physique +c + itap = itap + 1 + +c==================================================================== +c +c Epaisseurs couches + + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + +c==================================================================== +c Orbite et eclairement +c==================================================================== + +c Pour TITAN: +c calcul de la longitude solaire + CALL solarlong(rjourvrai+gmtime,zls) + zlsdeg = zls*180./RPI ! zls est en radians !! + print*,'Ls',zlsdeg + + CALL orbite(zls,dist,pdecli) + IF (debut) zlsm1=zls + +c dans zenang, Ls en degres ; dans mucorr, Ls en radians + call mucorr(klon,zls,latitude_deg,rmu0bar,fractbar) + IF (cycle_diurne) THEN + zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) + CALL zenang(zlsdeg,gmtime,zdtime,latitude_deg,longitude_deg, + & rmu0,fract) + ELSE + rmu0 = rmu0bar + fract = fractbar + ENDIF + +c==================================================================== +c Appeler la diffusion verticale (programme de couche limite) +c==================================================================== + +c------------------------------- +c TEST: on ne tient pas compte des calculs de clmain mais on force +c l'equilibre radiatif du sol + if (1.eq.0) then + if (debut) then + print*,"ATTENTION, CLMAIN SHUNTEE..." + endif + + DO i = 1, klon + sens(i) = 0.0e0 ! flux de chaleur sensible au sol + fder(i) = 0.0e0 + dlw(i) = 0.0e0 + ENDDO + +c Incrementer la temperature du sol +c + DO i = 1, klon + d_ts(i) = dtime * radsol(i)/22000. !valeur calculee par GCM pour I=200 + ftsol(i) = ftsol(i) + d_ts(i) + do j=1,nsoilmx + ftsoil(i,j)=ftsol(i) + enddo + ENDDO + +c------------------------------- + else +c------------------------------- + + fder = dlw + +c print*,"radsol avant clmain=",radsol(klon/2) +c print*,"solsw avant clmain=",solsw(klon/2) +c print*,"sollw avant clmain=",sollw(klon/2) + +! ADAPTATION GCM POUR CP(T) + + CALL clmain(dtime,itap, + e t_seri,u_seri,v_seri, + e rmu0, + e ftsol, + $ ftsoil, + $ paprs,pplay,ppk,radsol,falbe, + e solsw, sollw, sollwdown, fder, + e longitude_deg, latitude_deg, dx, dy, + e debut, lafin, + s d_t_vdf,d_u_vdf,d_v_vdf,d_ts, + s fluxt,fluxu,fluxv,cdragh,cdragm, + s dsens, + s ycoefh,yu1,yv1) + +c print*,"radsol apres clmain=",radsol(klon/2) +c print*,"solsw apres clmain=",solsw(klon/2) +c print*,"sollw apres clmain=",sollw(klon/2) + +CXXX Incrementation des flux + DO i = 1, klon + sens(i) = - fluxt(i,1) ! flux de chaleur sensible au sol + fder(i) = dlw(i) + dsens(i) + ENDDO +CXXX + + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k) + d_t_vdf(i,k)= d_t_vdf(i,k)/dtime ! K/s + u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k) + d_u_vdf(i,k)= d_u_vdf(i,k)/dtime ! (m/s)/s + v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k) + d_v_vdf(i,k)= d_v_vdf(i,k)/dtime ! (m/s)/s + ENDDO + ENDDO + +c call WriteField_phy('physiq_dtvdf',d_t_vdf,klev) +c call WriteField_phy('physiq_duvdf',d_u_vdf,klev) +c call WriteField_phy('physiq_dvvdf',d_v_vdf,klev) + +C TRACEURS + + d_tr_vdf = 0. + if (iflag_trac.eq.1) then + DO iq=1, nqmax + CALL cltrac(dtime,ycoefh,t_seri, + s tr_seri(1,1,iq),source, + e paprs, pplay,delp, + s d_tr_vdf(1,1,iq)) + tr_seri(:,:,iq) = tr_seri(:,:,iq) + d_tr_vdf(:,:,iq) + d_tr_vdf(:,:,iq)= d_tr_vdf(:,:,iq)/dtime ! /s + ENDDO + endif + + IF (if_ebil.ge.2) THEN + ztit='after clmain' + CALL diagetpq(cell_area,ztit,ip_ebil,2,1,dtime + e , t_seri,zero_v2,zero_v2,zero_v2,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil + e , zero_v, zero_v, zero_v, zero_v, sens + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +C +c +c Incrementer la temperature du sol +c +c print*,'Tsol avant clmain:',ftsol(1) + DO i = 1, klon + ftsol(i) = ftsol(i) + d_ts(i) + ENDDO +c print*,'DTsol apres clmain:',d_ts(klon/2) +c print*,'Tsol apres clmain:',ftsol(1) + +c Calculer la derive du flux infrarouge +c + DO i = 1, klon + dlw(i) = - 4.0*emis*RSIGMA*ftsol(i)**3 + ENDDO + +c------------------------------- + endif ! fin du TEST + +c +c Appeler l'ajustement sec +c +c=================================================================== +c Convection seche +c=================================================================== +c + d_t_ajs(:,:)=0. + d_u_ajs(:,:)=0. + d_v_ajs(:,:)=0. + d_tr_ajs(:,:,:)=0. +c + IF(prt_level>9)WRITE(lunout,*) + . 'AVANT LA CONVECTION SECHE , iflag_ajs=' + s ,iflag_ajs + + if(iflag_ajs.eq.0) then +c Rien +c ==== + IF(prt_level>9)WRITE(lunout,*)'pas de convection' + + else if(iflag_ajs.eq.1) then + +c Ajustement sec +c ============== + IF(prt_level>9)WRITE(lunout,*)'ajsec' + +! ADAPTATION GCM POUR CP(T) + CALL ajsec(paprs, pplay, ppk, t_seri, u_seri, v_seri, nqmax, + . tr_seri, d_t_ajs, d_u_ajs, d_v_ajs, d_tr_ajs) + +! ADAPTATION GCM POUR CP(T) + do i=1,klon + flux_ajs(i,1) = 0.0 + do j=2,klev + flux_ajs(i,j) = flux_ajs(i,j-1) + . + cpdet(t_seri(i,j-1))/RG*d_t_ajs(i,j-1)/dtime + . *delp(i,j-1) + enddo + enddo + + t_seri(:,:) = t_seri(:,:) + d_t_ajs(:,:) + d_t_ajs(:,:)= d_t_ajs(:,:)/dtime ! K/s + u_seri(:,:) = u_seri(:,:) + d_u_ajs(:,:) + d_u_ajs(:,:)= d_u_ajs(:,:)/dtime ! (m/s)/s + v_seri(:,:) = v_seri(:,:) + d_v_ajs(:,:) + d_v_ajs(:,:)= d_v_ajs(:,:)/dtime ! (m/s)/s + if (iflag_trac.eq.1) then + tr_seri(:,:,:) = tr_seri(:,:,:) + d_tr_ajs(:,:,:) + d_tr_ajs(:,:,:)= d_tr_ajs(:,:,:)/dtime ! /s + endif + +c call WriteField_phy('physiq_dtajs',d_t_ajs,klev) +c call WriteField_phy('physiq_duajs',d_u_ajs,klev) +c call WriteField_phy('physiq_dvajs',d_v_ajs,klev) + + endif +c + IF (if_ebil.ge.2) THEN + ztit='after dry_adjust' + CALL diagetpq(cell_area,ztit,ip_ebil,2,2,dtime + e , t_seri,zero_v2,zero_v2,zero_v2,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil + e , zero_v, zero_v, zero_v, zero_v, sens + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + +c==================================================================== +c MICROPHYSIQUE ET CHIMIE +c==================================================================== + + d_tr_mph(:,:,:)=0. + d_tr_kim(:,:,:)=0. + +c on recupere tr_seri inchange, d_tr_micro, d_tr_chim, tous les trois sur nqmax +c on recupere aussi qaer pour le mettre dans les sorties +c si microfi=1, sortie de qaer(1:nmicro) +c si nmicro != nqmax et si chimi, sortie de tr_seri(nmicro+1:nqmax) + +c faire un test comme pour rayonnement, avec chimi en plus comme flag, +c pour voir si chimie appelee -> bouleen, qui passe dans phytrac. +c faut aussi le pas de temps chimique: dtimechim, a passer.. + + appel_chim = 0 + IF (MOD(itapchim,chimpas).EQ.0) THEN +c print*,'CHIMIE ', +c $ ' (itapchim=',itapchim,'/chimpas=',chimpas,')' + appel_chim = 1 + itapchim = 0 + ENDIF + itapchim = itapchim + 1 + + if (iflag_trac.eq.1) then +c call WriteField_phy('physiq_qaer01', +c . qaer(:,:,1),klev) +c call WriteField_phy('physiq_qaer10', +c . qaer(:,:,10),klev) +c call WriteField_phy('physiq_tr_seri01', +c . tr_seri(:,:,1),klev) +c call WriteField_phy('physiq_tr_seri10', +c . tr_seri(:,:,10),klev) + +c call begintime(tt0) +c in phytrac call, mu0 and fract are only used in brume +c so we need to pass either rmu0 ou rmu0bar depending on +c moyzon_mu + if (moyzon_mu) then + call phytrac (debut,lafin, + . nqmax,nmicro,dtime,appel_chim,dtimechim, + . paprs,pplay,delp,t,rmu0bar,fractbar,pdecli,zls, + . yu1,yv1,zzlev,zzlay,ftsol, + . tr_seri,qaer,d_tr_mph,d_tr_kim, + . fclat,reservoir) + else + call phytrac (debut,lafin, + . nqmax,nmicro,dtime,appel_chim,dtimechim, + . paprs,pplay,delp,t,rmu0,fract,pdecli,zls, + . yu1,yv1,zzlev,zzlay,ftsol, + . tr_seri,qaer,d_tr_mph,d_tr_kim, + . fclat,reservoir) + endif + +c call endtime(tt0,tt1) +c ttphytra=ttphytra+tt1 + +c ----- ICI on ajuste radsol en tenant compte du flux de chaleur latente +c d'evaporation du reservoir. +c NOTE : c'est pas tres elegant mais ca permet d'eviter d'aller +c toucher a clmain. + if (clouds.eq.1) then + radsol(:) = radsol(:)+fclat(:) !test pas de flx de chaleur latente + endif + + if (microfi.ge.1) then + tr_seri(:,:,1:nmicro) = tr_seri(:,:,1:nmicro) + . + d_tr_mph(:,:,1:nmicro)*dtime +c call WriteField_phy('physiq_d_tr_mph01', +c . d_tr_mph(:,:,1),klev) +c call WriteField_phy('physiq_d_tr_mph10', +c . d_tr_mph(:,:,10),klev) + endif +c PAS ELEGANT mais je n'ai pas trouve d'autres solutions : +c Il semblerait qu'il y ait un probleme lorsque les tendances de traceurs +c retourne des traceurs nuls et il y a parfois des valeurs negatives qui trainent. +c Pour ne diffuser le probleme, on force les valeurs negatives a ZERO. + DO iq=1,nmicro + DO i=1,klon + DO l=1,klev + if (tr_seri(i,l,iq).lt.0.) then + tr_seri(i,l,iq) = 0. + endif + ENDDO + ENDDO + ENDDO + +c condensation: +c NE PAS OUBLIER LA CONDENSATION DES NUAGES !!!! + if ((clouds.eq.1.or.(chimi)).and.nqmax.gt.nmicro) then + tr_seri(:,:,nmicro+1:nqmax) = tr_seri(:,:,nmicro+1:nqmax) + . + d_tr_mph(:,:,nmicro+1:nqmax)*dtime + endif + +c chimie: + if ((chimi).and.(nqmax.gt.nmicro)) then + tr_seri(:,:,:) = tr_seri(:,:,:) + d_tr_kim(:,:,:)*dtime + endif + + endif !iflag_trac=1 + +c ch4=0. +c do l=1,llm +c ch4(1,l) = tr_seri(1,l,ich4) +c do j=2,jjm +c ig0=1+(j-2)*iim +c do i=1,iim +c ch4(j,l)= ch4(j,l) + tr_seri(ig0+i,l,ich4)/iim +c enddo +c enddo +c ch4(jjm+1,l) = tr_seri(klon,l,ich4) +c enddo +c do j=1,jjm+1 +c write(501,*) j,ch4(j,1) +c enddo +c do l=1,llm +c write(502,'(I3,49(ES24.17,1X))') l, +c & (ch4(j,l),j=1,jjm+1) +c enddo +c write(501,*) "" +c write(502,*) "" + +c------------------ +c test condensation +c do i=1,nqmax +c if(tname(i).eq."HCN") then +c print*,"HCN=" +c do k=1,klev +c print*,k,tr_seri(klon/2,k,i),d_tr_mph(klon/2,k,i)*dtime +c v ,d_tr_kim(klon/2,k,i)*dtime +c enddo +c stop +c endif +c enddo +c------------------ + +c==================================================================== +c RAYONNEMENT +c==================================================================== + + IF (MOD(itaprad,radpas).EQ.0) THEN +c print*,'RAYONNEMENT ', +c $ ' (itaprad=',itaprad,'/radpas=',radpas,')' + +c ATTENTION, (klon/2) ne marche pas toujours............ +c print*,"radsol avant radlwsw=",radsol(klon/2) +c print*,"solsw avant radlwsw=",solsw(klon/2) +c print*,"sollw avant radlwsw=",sollw(klon/2) +c print*,"avant radlwsw" + +c ---------------- +c Calcul du rayon moyen des gouttes et des fractions volumique pour le TR +c ---------------- + IF (clouds.eq.1) THEN + DO i=1,klon + DO j=1,klev + rmcbar(i,j)=rmcbar(i,j)/MAX(REAL(ncount(i,j)),1.) + xfbar(i,j,:)=xfbar(i,j,:)/MAX(REAL(ncount(i,j)),1.) + ENDDO + ENDDO + ENDIF + +c call begintime(tt0) + CALL radlwsw + e (dist, rmu0, fract, zzlev, + e paprs, pplay,ftsol, t_seri, nqmax, nmicro, + c tr_seri, qaer) +c print*,"apres radlwsw" + +c call endtime(tt0,tt1) +c ttrad=ttrad+tt1 + +c print*,"apres radlwsw" +c mise a zero du rayon moyen des gouttes et des fractions volumique + IF (clouds.eq.1) THEN + rmcbar(:,:) = 0. + xfbar(:,:,:) = 0. + ncount(:,:) = 0 + ENDIF + + itaprad = 0 + DO k = 1, klev + DO i = 1, klon + dtrad(i,k) = heat(i,k)-cool(i,k) !K/s + ENDDO + ENDDO + +c call WriteField_phy('physiq_heat',heat,klev) +c call WriteField_phy('physiq_cool',cool,klev) + + ENDIF + itaprad = itaprad + 1 +c==================================================================== +c +c Ajouter la tendance des rayonnements (tous les pas) +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + dtrad(i,k) * dtime + ENDDO + ENDDO + + IF (if_ebil.ge.2) THEN + ztit='after rad' + CALL diagetpq(cell_area,ztit,ip_ebil,2,2,dtime + e , t_seri,zero_v2,zero_v2,zero_v2,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil + e , topsw, toplw, solsw, sollw, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +c + +c==================================================================== +c Calcul des gravity waves FLOTT +c==================================================================== +c + if (ok_orodr.or.ok_gw_nonoro) then +c CALCUL DE N2 + do i=1,klon + do k=2,klev + ztlev(i,k) = (t_seri(i,k)+t_seri(i,k-1))/2. + zpklev(i,k) = sqrt(ppk(i,k)*ppk(i,k-1)) + enddo + enddo + call t2tpot(klon*klev,ztlev, ztetalev,zpklev) + call t2tpot(klon*klev,t_seri,ztetalay,ppk) + do i=1,klon + do k=2,klev + zdtetalev(i,k) = ztetalay(i,k)-ztetalay(i,k-1) + zdzlev(i,k) = (zphi(i,k)-zphi(i,k-1))/RG + zn2(i,k) = RG*zdtetalev(i,k)/(ztetalev(i,k)*zdzlev(i,k)) + zn2(i,k) = max(zn2(i,k),1.e-12) ! securite + enddo + zn2(i,1) = 1.e-12 ! securite + enddo + + endif + +c ----------------------------ORODRAG + IF (ok_orodr) THEN +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 +c IF ((zstd(i).gt.10.0)) THEN + IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c +c A ADAPTER POUR VENUS!!! + CALL drag_noro(klon,klev,dtime,paprs,pplay,pphi,zn2, + e zmea,zstd, zsig, zgam, zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrdr, zvstrdr, + s d_t_oro, d_u_oro, d_v_oro) + +c print*,"d_u_oro=",d_u_oro(klon/2,:) +c ajout des tendances + t_seri(:,:) = t_seri(:,:) + d_t_oro(:,:) + d_t_oro(:,:)= d_t_oro(:,:)/dtime ! K/s + u_seri(:,:) = u_seri(:,:) + d_u_oro(:,:) + d_u_oro(:,:)= d_u_oro(:,:)/dtime ! (m/s)/s + v_seri(:,:) = v_seri(:,:) + d_v_oro(:,:) + d_v_oro(:,:)= d_v_oro(:,:)/dtime ! (m/s)/s +c + ELSE + d_t_oro = 0. + d_u_oro = 0. + d_v_oro = 0. + zustrdr = 0. + zvstrdr = 0. +c + ENDIF ! fin de test sur ok_orodr +c +c ----------------------------OROLIFT + IF (ok_orolf) THEN + print*,"ok_orolf NOT IMPLEMENTED !" + stop +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 + IF ((zpic(i)-zmea(i)).GT.100.) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c +c A ADAPTER POUR VENUS ET TITAN!!! +c CALL lift_noro(klon,klev,dtime,paprs,pplay, +c e latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, +c e igwd,idx,itest, +c e t_seri, u_seri, v_seri, +c s zulow, zvlow, zustrli, zvstrli, +c s d_t_lif, d_u_lif, d_v_lif ) + +c +c ajout des tendances + t_seri(:,:) = t_seri(:,:) + d_t_lif(:,:) + d_t_lif(:,:)= d_t_lif(:,:)/dtime ! K/s + u_seri(:,:) = u_seri(:,:) + d_u_lif(:,:) + d_u_lif(:,:)= d_u_lif(:,:)/dtime ! (m/s)/s + v_seri(:,:) = v_seri(:,:) + d_v_lif(:,:) + d_v_lif(:,:)= d_v_lif(:,:)/dtime ! (m/s)/s +c + ELSE + d_t_lif = 0. + d_u_lif = 0. + d_v_lif = 0. + zustrli = 0. + zvstrli = 0. +c + ENDIF ! fin de test sur ok_orolf + +c ---------------------------- NON-ORO GRAVITY WAVES + IF(ok_gw_nonoro) then + + abort_message="Option non developpee pour Titan" + call abort_gcm(modname,abort_message,1) +c A FAIRE POUR TITAN +c call flott_gwd_ran(klon,klev,dtime,pplay,zn2, +c e t_seri, u_seri, v_seri, +c o zustrhi,zvstrhi, +c o d_t_hin, d_u_hin, d_v_hin) + +c ajout des tendances + +c t_seri(:,:) = t_seri(:,:) + d_t_hin(:,:) +c d_t_hin(:,:)= d_t_hin(:,:)/dtime ! K/s +c u_seri(:,:) = u_seri(:,:) + d_u_hin(:,:) +c d_u_hin(:,:)= d_u_hin(:,:)/dtime ! (m/s)/s +c v_seri(:,:) = v_seri(:,:) + d_v_hin(:,:) +c d_v_hin(:,:)= d_v_hin(:,:)/dtime ! (m/s)/s + + ELSE + d_t_hin = 0. + d_u_hin = 0. + d_v_hin = 0. + zustrhi = 0. + zvstrhi = 0. + + ENDIF ! fin de test sur ok_gw_nonoro + +c==================================================================== +c Transport de ballons +c==================================================================== + if (ballons.eq.1) then + CALL ballon(30,pdtphys,rjourvrai,gmtime, + & latitude_deg,longitude_deg, +c C t,pplay,u,v,pphi) ! alt above surface (smoothed for GCM) + C t,pplay,u,v,zphi) ! alt above planet average radius + endif !ballons + +c==================================================================== +c Bilan de mmt angulaire +c==================================================================== + if (bilansmc.eq.1) then +CMODDEB FLOTT +C CALCULER LE BILAN DE MOMENT ANGULAIRE (DIAGNOSTIQUE) +C STRESS NECESSAIRES: COUCHE LIMITE ET TOUTE LA PHYSIQUE + + DO i = 1, klon + zustrph(i)=0. + zvstrph(i)=0. + zustrcl(i)=0. + zvstrcl(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + zustrcl(i)=zustrcl(i)+d_u_vdf(i,k)* + c (paprs(i,k)-paprs(i,k+1))/rg + zvstrcl(i)=zvstrcl(i)+d_v_vdf(i,k)* + c (paprs(i,k)-paprs(i,k+1))/rg + ENDDO + ENDDO + + CALL aaam_bud (27,klon,klev,rjourvrai,gmtime, + C ra,rg,romega, + C latitude_deg,longitude_deg,pphis, + C zustrdr,zustrli,zustrcl, + C zvstrdr,zvstrli,zvstrcl, + C paprs,u,v) + +CCMODFIN FLOTT + endif !bilansmc + +c==================================================================== +c==================================================================== +c Calculer le transport de l'eau et de l'energie (diagnostique) +c +c A REVOIR POUR VENUS ET TITAN... +c +c CALL transp (paprs,ftsol, +c e t_seri, q_seri, u_seri, v_seri, zphi, +c s ve, vq, ue, uq) +c +c==================================================================== +c+jld ec_conser + DO k = 1, klev + DO i = 1, klon + d_t_ec(i,k)=0.5/cpdet(t_seri(i,k)) + $ *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2) + t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k) + d_t_ec(i,k) = d_t_ec(i,k)/dtime + END DO + END DO + do i=1,klon + flux_ec(i,1) = 0.0 + do j=2,klev + flux_ec(i,j) = flux_ec(i,j-1) + . +cpdet(t_seri(i,j-1))/RG*d_t_ec(i,j-1)*delp(i,j-1) + enddo + enddo + +c-jld ec_conser +c==================================================================== + IF (if_ebil.ge.1) THEN + ztit='after physic' + CALL diagetpq(cell_area,ztit,ip_ebil,1,1,dtime + e , t_seri,zero_v2,zero_v2,zero_v2,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + call diagphy(cell_area,ztit,ip_ebil + e , topsw, toplw, solsw, sollw, sens + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) +C + d_h_vcol_phy=d_h_vcol +C + END IF +C +c======================================================================= +c SORTIES +c======================================================================= + +c Convertir les incrementations en tendances +c + DO k = 1, klev + DO i = 1, klon + d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime + d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime + d_t(i,k) = ( t_seri(i,k) - t(i,k) ) / dtime + ENDDO + ENDDO +c + DO iq = 1, nqmax + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = ( tr_seri(i,k,iq) - qx(i,k,iq) ) / dtime + ENDDO + ENDDO + ENDDO + +c------------------------ +c Calcul moment cinetique +c------------------------ +c TEST... +c mangtot = 0.0 +c DO k = 1, klev +c DO i = 1, klon +c mang(i,k) = RA*cos(latitude(i)) +c . *(u_seri(i,k)+RA*cos(latitude(i))*ROMEGA) +c . *cell_area(i)*(paprs(i,k)-paprs(i,k+1))/RG +c mangtot=mangtot+mang(i,k) +c ENDDO +c ENDDO +c print*,"Moment cinetique total = ",mangtot +c +c------------------------ +c +c Sauvegarder les valeurs de t et u a la fin de la physique: +c + DO k = 1, klev + DO i = 1, klon + u_ancien(i,k) = u_seri(i,k) + t_ancien(i,k) = t_seri(i,k) + ENDDO + ENDDO +c +c============================================================= +c Ecriture des sorties +c============================================================= + +#ifdef CPP_IOIPSL + +#ifdef histday +#include "write_histday.h" +#endif + +#ifdef histmth +#include "write_histmth.h" +#endif + +#ifdef histins +#include "write_histins.h" +#endif + +#endif + +c==================================================================== +c Si c'est la fin, il faut conserver l'etat de redemarrage +c==================================================================== +c + IF (lafin) THEN + itau_phy = itau_phy + itap + lsinit = zlsdeg + CALL phyredem ("restartphy.nc") + +c--------------FLOTT +CMODEB LOTT +C FERMETURE DU FICHIER FORMATTE CONTENANT LES COMPOSANTES +C DU BILAN DE MOMENT ANGULAIRE. + if (bilansmc.eq.1) then + write(*,*)'Fermeture de aaam_bud.out (FL Vous parle)' + close(27) + close(28) + endif !bilansmc +CMODFIN +c------------- +c--------------SLEBONNOIS +C FERMETURE DES FICHIERS FORMATTES CONTENANT LES POSITIONS ET VITESSES +C DES BALLONS + if (ballons.eq.1) then + write(*,*)'Fermeture des ballons*.out' + close(30) + close(31) + close(32) + close(33) + close(34) + endif !ballons +c------------- + ENDIF + + END SUBROUTINE physiq + + END MODULE physiq_mod + Index: trunk/LMDZ.TITAN.old/libf/phytitan/phytrac.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/phytrac.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/phytrac.F (revision 1643) @@ -0,0 +1,743 @@ + SUBROUTINE phytrac (firstcall,lastcall, + . nqmax,nmicro,ptimestep,appkim,dtkim, + . pplev,pplay,delp,ptemp,pmu0,pfract,pdecli, + . lonsol, + . pu,pv,pzlev,pzlay,ftsol, + . tr_seri,qaer,d_tr_mph,d_tr_kim, + . fclat,reservoir) + +c====================================================================== +c S. Lebonnois, mai 2008 +c +c Arguments: +c +c firstcall----input-L-variable logique indiquant le premier passage +c lastcall-----input-L-variable logique indiquant le dernier passage +c nqmax--------input-I-nombre de traceurs (total) +c nmicro-------input-I-nombre de traceurs microphysiques !! doivent etre toujours en premiers!! +c ptimestep----input-R-pas d integration pour la physique (seconde) +c appkim-------input-I-appel a la chimie +c dtkim--------input-R-pas de temps chimique (seconde) +c pplev--------input-R-pression pour chaque inter-couche (en Pa) +c pplay--------input-R-pression pour chaque couche (en Pa) +c delp---------input-R-epaisseur d'une couche (en Pa) +c ptemp--------input-R-temperature (K) +c pmu0---------input-R-cos angle zenithal +c pfract-------input-R-fractional day +c pdecli-------input-R-declinaison en radian +c lonsol-------input-R-longitude solaire en radian +c pu-----------input-R-vitesse dans la direction X (de O a E) en m/s (1ere couche) +c pv-----------input-R-vitesse Y (de S a N) en m/s (1ere couche) +c pzlev--------input-R-altitude pour chaque inter-couche (en m) +c pzlay--------input-R-altitude pour chaque couche (en m) +c ftsol--------input-R-temperature au sol (en K) +c tr_seri------input-R-mass mixing ratio traceurs (kg/kg) +c d_tr_mph----output-R-tendance microphysique de "qx" (kg/kg/s) +c d_tr_kim----output-R-tendance chimique de "qx" (kg/kg/s) +c fclat--------output-R-flux de chaleur latente d'evaporation du reservoir CH4 (J/m2/s) +c reservoir----outpur-R-un reservoir de surface !!! (m) +c====================================================================== + USE infotrac_phy, ONLY: tname + use dimphy + USE common_mod, only: rmcbar,xfbar,ncount, + & flxesp_i,tau_drop,tau_aer,solesp,precip, + & evapch4,occcld_m,occcld,satch4,satc2h6,satc2h2,rmcloud + USE moyzon_mod + USE write_field_phy + USE logic_mod, ONLY: moyzon_ch,moyzon_mu + IMPLICIT none +#include "dimensions.h" +#include "clesphys.h" +#include "YOMCST.h" +#include "microtab.h" +#include "varmuphy.h" +#include "itemps.h" + +c====================================================================== +c Variables argument: +c + LOGICAL firstcall,lastcall + INTEGER nqmax,nmicro,nlat,appkim + REAL ptimestep,dtkim + REAL pplev(klon,klev+1),pplay(klon,klev+1),delp(klon,klev) + REAL ptemp(klon,klev) + REAL pmu0(klon), pfract(klon), pdecli, lonsol + REAL pu(klon),pv(klon) + REAL pzlev(klon,klev+1),pzlay(klon,klev) + REAL ftsol(klon) + REAL tr_seri(klon,klev,nqmax) + REAL qaer(klon,klev,nqmax) + REAL d_tr_mph(klon,klev,nqmax),d_tr_kim(klon,klev,nqmax) + REAL fclat(klon) + REAL reservoir(klon) + +c====================================================================== +c Local variables + REAL qaer0(klon,klev,nqmax) + REAL prec(klon,5) + + REAL rcloud(klon,klev,nrad),xfrac(klon,klev,4) + + REAL vcl,nuc,xgsn,xmsn,xesn,xasn + + + ReAL gaz1(klon,klev),gaz2(klon,klev),gaz3(klon,klev) + + REAL socccld + +c grandeurs en moyennes zonales + REAL zplev(klon,klev+1),zplay(klon,klev) + REAL zzlev(klon,klev+1),zzlay(klon,klev) + REAL ztemp(klon,klev), delpbar(klon,klev) + real temp_eq(klev),press_eq(klev) + REAL qaer0bar(klon,klev,nqmax) ! et non nmicro... Permet nmicro=0. + REAL zdqmufi(klon,klev,nqmax) + REAL ychim(klon,klev,nqmax-nmicro) +c La saturation n est calculee qu une seule fois: sauvegarde qysat +c La chimie n est pas calculee tous les pas, il faut donc +c sauvegarder les sorties de la chimie + REAL,save,allocatable :: qysat(:,:),pdyfi(:,:,:) + + character*10 nomqy(nqmax-nmicro+1) + integer i,j,k,l,iq,ig0 + +c indice des esp chimiques utilisees dans la microfi + integer icldch4,icldc2h6,icldc2h2 + save icldch4,icldc2h6,icldc2h2 + + real fte,ftm,Lvch4 + + REAL tmp,ex,kmin,kmax,dqsq + REAL dqch4 + +c====================================================================== +c====================================================================== + + if (firstcall) then + allocate(qysat(klev,nqmax-nmicro),pdyfi(klon,klev,nqmax-nmicro)) + +c -------- Quelques verifications au demarrage sur les tailles des tableaux. + IF (microfi.ge.1) then +c Faire de la microphysique sans traceurs... bon courage ! + if (nmicro.le.0) then + print*,"aLeRtE cRiTiQuE !!!" + print*,"Vous faites de la microphysique sans traceurs" + print*,"microphysique..." + print*,"Je m'arrete et vous laisse reflechir !" + stop + endif +c Nombre de traceurs incompatibles avec la microphysique. + if ((nmicro.ne.ntype*nrad).and.(clouds.eq.1)) then + print*,"aLeRtE cRiTiQuE !!!" + print*,"Nb trac imcompatible avec la microphysique." + print*,nmicro,ntype*nrad + stop + endif + if ((nmicro.ne.nrad).and.(clouds.eq.0)) then + print*,"aLeRtE cRiTiQuE !!!" + print*,"Nb trac imcompatible avec la microphysique." + print*,nmicro,nrad + stop + endif + ENDIF + + endif ! firstcall + +c RAZ des sorties : les moyennes se font directement dans IOIPSL : +c + flxesp_i(:,:,:) = 0. + tau_drop(:,:) = 0. + tau_aer(:,:,:) = 0. + solesp(:,:,:) = 0. + precip(:,:) = 0. ! c'est uniquement une sortie en um/s +c + prec(:,:) = 0. ! c'est la variable temporaire des precipitions de la microfi + ! prec est en m (metre precipitable) + +c----------------------------------------------------------------------- +c convertion moyennes zonales et changement d unites pour microphy +c --------------------------------- + +c print*,'CONVERSION 2D ET CHANGEMENT UNITES (PHYTRAC)' + +c ------------------- +c Gestion de la temperature et de la pression : +c Utilisation des moyennes zonales: + +c soit la chimie est active, soit la microphysique se fait en 2D. + IF (chimi.or.microfi.eq.1) THEN + zplev(:,:) = zplevbar(:,:) + zplay(:,:) = zplaybar(:,:) + zzlev(:,:) = zzlevbar(:,:) + zzlay(:,:) = zzlaybar(:,:) + ztemp(:,:) = ztfibar(:,:) + ychim = 0.0 + ENDIF + +c Si la microphysique est faite en 2D: + IF (microfi.eq.1) THEN + DO l=1,llm + DO i = 1, klon + delpbar(i,l) = zplevbar(i,l) - zplevbar(i,l+1) + ENDDO + ENDDO +c Traceurs microphysiques: passage en extensif: n/kg --> n/m^2 + DO iq=1,nmicro + qaer(:,:,iq) = zqfibar(:,:,iq)*delpbar(:,:)/RG + DO l=1,klev + DO i = 1, klon + if (qaer(i,l,iq).lt.0.) then + print*,"NEGS ICI ICI !!!!",qaer(i,l,iq),i,l,iq + qaer(i,l,iq)=0. +c stop + endif + if (delpbar(i,l).lt.0.) then + print*,"NEGS DELP ICI !!!!",i,l,iq,delpbar(i,l) + stop + endif + ENDDO + ENDDO + qaer0(:,:,iq)= tr_seri(:,:,iq)*delp(:,:)/RG + qaer0bar(:,:,iq) = qaer(:,:,iq) + ENDDO + ENDIF + +c Si la microphysique est faite en 3D: + IF (microfi.eq.2) THEN + zplev(:,:) = pplev(:,:) + zplay(:,:) = pplay(:,:) + zzlev(:,:) = pzlev(:,:) + zzlay(:,:) = pzlay(:,:) + ztemp(:,:) = ptemp(:,:) +c Traceurs microphysiques: passage en extensif: n/kg --> n/m^2 + DO iq=1,nmicro + qaer(:,:,iq) = tr_seri(:,:,iq)*delp(:,:)/RG + qaer0(:,:,iq)= tr_seri(:,:,iq)*delp(:,:)/RG + ENDDO + ENDIF + + do l=1,llm + temp_eq = tmoy + press_eq = playmoy/100. ! en mbar + enddo + +c ------------------- +c Extraction des gaz pour les nuages + IF ((microfi.ge.1).and.(clouds.eq.1)) THEN + +c recuperation des indices des gaz qui nous interesse + if (firstcall) then + icldch4=-1 + icldc2h6=-1 + icldc2h2=-1 + do i=1,nqmax + if (tname(i).eq."CH4") then + icldch4=i +c ich4=i + elseif (tname(i).eq."C2H6") then + icldc2h6=i + elseif (tname(i).eq."C2H2") then + icldc2h2=i + endif + enddo + if (icldch4 .eq.-1 .or. + & icldc2h6.eq.-1 .or. + & icldc2h2.eq.-1 ) then + print*, "Sacrebleu !!!" + print*, "Vous voulez faire des nuages sans gaz." + print*, "Mais vous etes inconscient. Je vais m'arreter la" + print*, "pour vous laisser reflechir au probleme" + STOP + endif + endif ! firstcall + +c Saturation et fraction molaire CLOUD +c Calcul des saturations pour les esp chimique de la muphy des nuages. +c On le fait ici pour les sortir dans physiq.F sans avoir a surcharger la routine. +c Elles passent ensuite dans un common pour passer dans les I/O. + + DO l=1,llm + DO i = 1, klon + call ch4sat(ptemp(i,l),pplay(i,l),tmp) !tmp en kg/kg ! + satch4(i,l) = tr_seri(i,l,icldch4)/(tmp*28./16.) + + call c2h6sat(ptemp(i,l),pplay(i,l),tmp) + satc2h6(i,l) =tr_seri(i,l,icldc2h6)/(tmp*28./30.) + + call c2h2sat(ptemp(i,l),pplay(i,l),tmp) + satc2h2(i,l) =tr_seri(i,l,icldc2h2)/(tmp*28./26.) + ENDDO + ENDDO + +c Copie des gaz (en 3D) <== UNIQUEMENT SI ON FAIT DES NUAGES + if (moyzon_mu) then + gaz1(:,:) = zqfibar(:,:,icldch4) + gaz2(:,:) = zqfibar(:,:,icldc2h6) + gaz3(:,:) = zqfibar(:,:,icldc2h2) + else + gaz1(:,:) = tr_seri(:,:,icldch4) + gaz2(:,:) = tr_seri(:,:,icldc2h6) + gaz3(:,:) = tr_seri(:,:,icldc2h2) + endif + + endif ! microfi.ge.1 + clouds.eq.1 +c ------------------- + +c AUTRES TRACEURS + + if (nqmax.gt.nmicro) then + do iq=nmicro+1,nqmax + if (moyzon_ch) then + ychim(:,:,iq-nmicro) = zqfibar(:,:,iq) + else + ychim(:,:,iq-nmicro) = tr_seri(:,:,iq) + endif + nomqy(iq-nmicro) = tname(iq) +c print*,iq-nmicro,nomqy(iq-nmicro) + enddo + nomqy(nqmax-nmicro+1) = "HV" + endif + +c----------------------------------------------------------------------- +c initialisation des qysat au premier appel: +c --------------------------------- + +c!! ATTENTION, qysat pris uniquement a l'equateur +c!! justifie puisque dans cette region, les var de t et p sont faibles... + + if (firstcall .and. chimi .and.(nqmax.gt.nmicro)) then + call inicondens(nqmax-nmicro,press_eq,temp_eq,nomqy,qysat) + endif + +c----------------------------------------------------------------------- +c Appel de la microphysique en 2D/3D !!!!!! +c -------------------------- + + IF(firstcall) THEN + print*,'MICROPHYSIQUE ',MICROFI + ENDIF + +c call begintime(tt0) + IF (MICROFI.eq.0) THEN +c PAS DE MICROPHYSIQUE : + IF (firstcall) THEN + print*,'MICROPHYSIQUE OFF-LINE',MICROFI + ENDIF + ELSE + zdqmufi = 0. ! ne sert que pour chimi pour condensation + call muphys(klon, + & zplev,zplay,zzlev,zzlay, + & ztemp,qaer,gaz1,gaz2,gaz3, + & nmicro,ptimestep, + & pmu0,pfract, +c -------- sorties diagnostiques + & flxesp_i, + & tau_drop,tau_aer, + & solesp,prec) + +c NOTES : +c Ici toutes nos sorties sont des champs 3D...(meme les diagnostiques) +c On a rien a faire mis a part copier les dq dans les d_tr + + ENDIF +c call endtime(tt0,tt1) +c ttmuphys=ttmuphys+tt1 + +c----------------------------------------------------------------------- +c Gestion des sources +c ------------- +c + IF (clouds.eq.1) THEN + IF (microfi.eq.1) THEN +c On repasse les gaz en 3D si on a fait de la microphysique en 2D + gaz1(:,:)=gaz1(:,:)*tr_seri(:,:,icldch4)/zqfibar(:,:,icldch4) + gaz2(:,:)=gaz2(:,:)*tr_seri(:,:,icldc2h6)/zqfibar(:,:,icldc2h6) + gaz3(:,:)=gaz3(:,:)*tr_seri(:,:,icldc2h2)/zqfibar(:,:,icldc2h2) + ENDIF +c Mise a jour du reservoir de CH4 (ie : seul le CH4 remplit le reservoir) + DO i=1,klon + reservoir(i) = reservoir(i)+prec(i,1) + ENDDO + + CALL sources(klon,klev,ptimestep,z0, + & pu,pv,pplev,pzlay,pzlev, + & gaz1,gaz2,gaz3, + & ftsol,evapch4,reservoir) + + ENDIF +c----------------------------------------------------------------------- +c Condensation +c ------------- + + IF ((chimi).and.(nqmax.gt.nmicro)) then + +c tendance (en /s) passee sur zdqmufi(nmicro+1 a nqmax) +c print*,'Condensation' + + do iq=1,nqmax-nmicro + do l=1,llm + do j=1,klon + if (ychim(j,l,iq).gt.qysat(l,iq)) then + zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+qysat(l,iq)) !delta y + . / ptimestep ! / dt + endif + enddo + enddo + enddo + + ENDIF + +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c eventuellement, modif initiale de la compo +c +c tendance (en /s) passee sur zdqmufi(nmicro+1 a nqmax) +c +c if (firstcall .and. chimi .and.(nqmax.gt.nmicro)) then +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c!!!remise de CH4 a 1.5%!!!!!!!!!!!!!!!!!!!!!! +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c do iq=1,nqmax-nmicro +c if (nomqy(iq).eq."CH4") then +c do l=1,llm +c do j=1,klon +c if (ychim(j,l,iq).le.0.015) then +c zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+0.015) !delta y +c . / ptimestep ! / dt +c endif +c enddo +c enddo +c endif +c enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c!!!remise de C2H2 a 1.e-5 max !!!!!!!!!!!!! +c!!!remise de C2H6 a 3.e-5 max !!!!!!!!!!!!! +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c do iq=1,nqmax-nmicro +c if (nomqy(iq).eq."C2H2") then +c do l=1,llm +c do j=1,klon +c if (ychim(j,l,iq).gt.1.e-5) then +c zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+1.e-5) !delta y +c . / ptimestep ! / dt +c endif +c enddo +c enddo +c endif +c if (nomqy(iq).eq."C2H6") then +c do l=1,llm +c do j=1,klon +c if (ychim(j,l,iq).gt.3.e-5) then +c zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+3.e-5) !delta y +c . / ptimestep ! / dt +c endif +c enddo +c enddo +c endif +c enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c endif +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +c ----- commentaire de fin (mise a jour des profil de fraction molaire) + +c----------------------------------------------------------------------- +c Appel de la chimie +c -------------------------- + + if((appkim.eq.1).and.(chimi)) then + print*,'On passe dans la CHIMIE' + +c do iq=1,nqmax-nmicro +c if (nomqy(iq).eq."C2H2") then +c print*,"C2H2top=",ychim(:,klev,iq) +c endif +c enddo + +c Appel Chimie +c ------------ + CALL calchim(klon,nqmax-nmicro,ychim,nomqy,pdecli,lonsol,dtkim, + . ztemp,zplay,zplev,zzlay,zzlev, + . pdyfi) +c ychim ne doit pas etre modifie, pdyfi en /s + + endif + +c----------------------------------------------------------------------- +c retour des tendances vers 3D +c --------------------------------- + +c call WriteField_phy('phytrac_qaer01',qaer(:,:,1),klev) + +c=============================== +c TRACEURS MICROPHYSIQUES +c +c=============================== +c ---> pas de microphysique + IF (microfi.eq.0) THEN + DO iq=1,nmicro + d_tr_mph(:,:,iq)=0. + ENDDO + ENDIF +c=============================== +c ---> microphysique 2D +c IF (microfi.eq.1) THEN +c DO iq=1,nmicro +c DO l=1,llm +c DO i=1,klon +c on repasse le champ de traceurs en 3D (pas les tendances) +c qaer est ce qui entre dans muphy, donc la moyenne zonale +c qaer0 est la valeur initiale du champ +c qaer0bar est la moyenne zonale initiale +c la variation relative pour une bande de latitude est donc (qaer/qaer0bar) +c la nouvelle valeur en un point (3D) est donc qaer0*(qaer/qaer0bar) +c et la tendance: qaer0*(qaer/qaer0bar)-qaer0 +c un petit patch : +c Si la moyenne zonale au depart est "nulle" : +c On a quand meme le droit de produire des traceurs dans la cellule. +c On considere donc que la valeur de sortie 3D correspond a la valeur de sortie 2D. +c Cela permet aussi entre autre d eviter les NaN pour les traceurs des nuages ! +c (au dessus de la tropo pas de nuages donc qaer(nrad+1:ntype*nrad) = 0 !!!) +c IF (qaer0bar(i,l,iq).gt.1e-100) THEN +c qaer(i,l,iq) = qaer0(i,l,iq) * +c & qaer(i,l,iq)/qaer0bar(i,l,iq) +c ENDIF +c La tendance correspond a (qaer-qaer0)/ptimestep +c d_tr_mph(i,l,iq) = (qaer(i,l,iq)-qaer0(i,l,iq))/ +c & ptimestep +c ENDDO +c ENDDO +c ENDDO +c ---> microphysique 3D +c ELSEIF(microfi.gt.1) THEN +c DO iq=1,nmicro +c d_tr_mph(:,:,iq)=(qaer(:,:,iq)-qaer0(:,:,iq))/ptimestep +c ENDDO +c ENDIF ! microfi + +c DO iq=1,nmicro +c Traceurs microphysiques: passage en intensif: n/m^2 --> n/kg +c d_tr_mph(:,:,iq) = d_tr_mph(:,:,iq)*RG/delp(:,:) +c ENDDO + +c=============================== +c TOUT CE QUI EST AU-DESSUS NE MARCHE PAS: PLEIN DE NEGS... +c CA MARCHE EN 3D, MAIS PAS EN MOY ZON... +c=============================== + +c ---> microphysique 2D + IF (microfi.eq.1) THEN + DO iq=1,nmicro + DO l=1,llm + DO i=1,klon +c ici, qaer correspond a la moy zonale modifiee par la microphys. +c Traceurs microphysiques: passage en intensif: n/m^2 --> n/kg +c en mettant ceci: + d_tr_mph(i,l,iq) = (qaer(i,l,iq)*RG/delpbar(i,l) + & -qaer0(i,l,iq)*RG/delp(i,l))/ + & ptimestep +c on remplace le champ 3D initial par la valeur modifiee de sa moyenne zonale +c => on remet un champ uniforme en zonal... + ENDDO + ENDDO + ENDDO +c ---> microphysique 3D + ELSEIF(microfi.gt.1) THEN + DO iq=1,nmicro + d_tr_mph(:,:,iq)=(qaer(:,:,iq)-qaer0(:,:,iq))/ptimestep +c Traceurs microphysiques: passage en intensif: n/m^2 --> n/kg + d_tr_mph(:,:,iq) = d_tr_mph(:,:,iq)*RG/delp(:,:) + ENDDO + ENDIF ! microfi + +c=============================== + +c AUTRES TRACEURS + + if ((chimi).and.(nqmax.gt.nmicro)) then +c on passe de pdyfi (tendance chimique en /s calculee quand chimie appelee) +c a d_tr_kim (tendance chimique 3D en /s, passee a physiq) +c et de zdqmufi a d_tr_mph (tendance condensation 3D en /s passee a physiq) + + DO iq=nmicro+1,nqmax + d_tr_kim(:,:,iq) = pdyfi(:,:,iq-nmicro) + & *tr_seri(:,:,iq)/ychim(:,:,iq-nmicro) + d_tr_mph(:,:,iq) = zdqmufi(:,:,iq) + & *tr_seri(:,:,iq)/ychim(:,:,iq-nmicro) + ENDDO + + endif ! chimi + +c-------------------------------------------------- +c CONDENSATION VIA MICROFI +c---------------------- +c La microphysique avec nuages doit se faire obligatoirement en 3D. (FAUX ACTUELLEMENT) +c Rien n empeche de faire la chimie en 2D. Cependant pour prendre en compte la +c condensation due a la microfi (en 3D) on recalcule la tendance finale pour +c les especes concernees (CH4, C2H6 pour le moment). + IF (microfi.ge.1.and.clouds.eq.1) THEN +c condensation CH4 + d_tr_mph(:,:,icldch4) =(gaz1(:,:)-tr_seri(:,:,icldch4)) + & /ptimestep +c condensation C2H6 + d_tr_mph(:,:,icldc2h6)=(gaz2(:,:)-tr_seri(:,:,icldc2h6)) + & /ptimestep +c condensation C2H2 + d_tr_mph(:,:,icldc2h2)=(gaz3(:,:)-tr_seri(:,:,icldc2h2)) + & /ptimestep + ENDIF + +c-------------------------------------------------- +c MISE A JOUR CH4 : (pour refixer la fraction +c molaire) +c-------------------------------------------------- +c IF (firstcall) THEN +c do i=1,klon +c do j=1,llm +c call ch4sat(ptemp(i,j),pplay(i,j),tmp) !tmp en kg/kg ! +c tmp=0.95*0.85*tmp*28./16. +c if (pplay(i,j).lt.20000.) then +c dqch4 = 1.4e-2 +c else +c dqch4 = tmp +c endif +c d_tr_mph(i,j,icldch4)=(-tr_seri(i,j,icldch4)+dqch4)/ +c & ptimestep +c enddo +c enddo +c +c ENDIF + +c-------------------------------------------------- +c CONVERSION PRECIPITATION : +c en microns/secondes +c-------------------------------------------------- + precip = prec * 1.e6 / ptimestep + + +c-------------------------------------------------- +c CALCUL DU FLUX DE CHALEUR LATENTE D EVAPORATION +c DU METHANE +c-------------------------------------------------- + IF (clouds.eq.1) THEN + DO i=1,klon + fte= (1.-ftsol(i)/305.5) + ftm= (1.-ftsol(i)/190.5) + if(ftm.le.1.e-3) ftm=1.e-3 + if(fte.le.1.e-3) fte=1.e-3 + Lvch4 =8.314*190.4* + & (7.08*ftm**0.354+10.95*1.1e-2*ftm**0.456) + & /mch4 + ! evapch4 en m3/m2 {ok} + ! 425 en kg/m3 + ! Lv en J/kg {ok} + ! ptimestep en s {ok} + fclat(i)=(evapch4(i)*Lvch4*rhoi_ch4) ! en J/m2/s + ENDDO + ENDIF + +c-------------------------------------------------- +c GESTION DES RAYONS DE GOUTTES POUR TR +c-------------------------------------------------- + IF (clouds.eq.1) THEN + +c Calcul du rayon des gouttes par bin ... +c---------------------------------------- + DO i=1,klon + DO j=1,klev + DO iq=1,nrad +* Rayon minimum selon la quantite de noyaux + IF (qaer(i,j,iq+nrad) .le. 1.e-5) THEN + rcloud(i,j,iq) = 1.e-10 + ELSE + rcloud(i,j,iq)= + & ((qaer(i,j,iq+2*nrad)/qaer(i,j,iq+nrad)+ + & qaer(i,j,iq+3*nrad)/qaer(i,j,iq+nrad) + + & v_e(iq))*0.75/RPI)**(1./3.) + ENDIF + ENDDO + ENDDO + ENDDO + +c .... et de leur rayon moyen total (tt bins confondu) +c------------------------------------------------------ + DO i=1,klon + socccld=0. + DO j=klev,1,-1 !de haut en bas pour le calcul des opacites + vcl=0. + nuc=0. + xgsn=0. + xmsn=0. + xesn=0. + xasn=0. + DO iq=1,nrad + vcl=vcl+qaer(i,j,iq+2*nrad)+ + & qaer(i,j,iq+3*nrad)+ + & qaer(i,j,iq+4*nrad)+ + & v_e(iq)*qaer(i,j,iq+nrad) ! volume des gouttes + nuc=nuc+qaer(i,j,iq+nrad) ! nombre de noyaux + xgsn=xgsn+qaer(i,j,iq+nrad)*v_e(iq) ! volume de noyaux + xmsn=xmsn+qaer(i,j,iq+2*nrad) ! volume de methane + xesn=xesn+qaer(i,j,iq+3*nrad) ! volume d' ethane + xasn=xasn+qaer(i,j,iq+4*nrad) ! volume d' acethylene + ENDDO + IF (nuc .le. 1.e-5) THEN + rmcloud(i,j)=1.0e-10 + xfrac(i,j,:)=0. + ELSE + IF(xgsn/vcl.lt.0. .or. xgsn/vcl.gt.1.001) + & print*, 'PB AVEC XFRAC:', i,j,xgsn,vcl + rmcloud(i,j)= ! rayon moyen des gouttes + & (vcl/nuc*0.75/RPI)**(1./3.) + xfrac(i,j,1)=xgsn/vcl ! fraction volumique noyau/goutte + xfrac(i,j,2)=xmsn/vcl ! fraction volumique CH4/goutte + xfrac(i,j,3)=xesn/vcl ! fraction volumique C2H6/goutte + xfrac(i,j,4)=xasn/vcl ! fraction volumique C2H2/goutte +c calcul du rayon moyen (moyenne temporelle) + rmcbar(i,j)=rmcbar(i,j)+rmcloud(i,j) + xfbar(i,j,:)=xfbar(i,j,:)+xfrac(i,j,:) + ncount(i,j) = ncount(i,j)+1 + ENDIF + socccld=socccld+RPI*(rmcloud(i,j)**2.)*nuc + occcld(i,j)=socccld + ENDDO + ENDDO +c +c OCCCLD +c Calcul le nombre d occurence d un nuage +c d opacite comprise en kmin et kmax +c k kmin kmax +c 1 0.0000000 0.10000000 +c 2 0.10000000 0.17782794 +c 3 0.17782794 0.31622776 +c 4 0.31622776 0.56234139 +c 5 0.56234139 1.0000000 +c 6 1.0000000 1.7782795 +c 7 1.7782795 3.1622777 +c 8 3.1622777 5.6234136 +c 9 5.6234136 10.000000 +c 10 10.000000 17.782795 +c 11 17.782795 31.622778 +c 12 31.622778 100000.00 +c +c mise a zero de occld_m + occcld_m=0. + DO i=1,klon + DO j=1,klev + DO k=1,12 + ex=10.**(0.25) + kmin=0. + kmax=1.e5 + if(k.ne.1) kmin=0.1*ex**(k-2) + if(k.ne.12) kmax=0.1*ex**(k-1) + if(occcld(i,j).ge.kmin .and. occcld(i,j).lt.kmax) + & occcld_m(i,j,k)=1. + ENDDO + ENDDO + ENDDO + ENDIF ! fin condition clouds => pas besoin de calculer des rayons + + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/pia.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pia.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pia.F (revision 1643) @@ -0,0 +1,20 @@ + SUBROUTINE PIA(K,TBAR,PNN,PCC,PCN,PHN) + PARAMETER (NSPECI=46, NTEMPS=14) + REAL PIANN,PIACC,PIACN,PIAHN + COMMON /PIAC/ PIANN(NSPECI,NTEMPS),PIACC(NSPECI,NTEMPS) + & ,PIACN(NSPECI,NTEMPS),PIAHN(NSPECI,NTEMPS),TMIN,TMAX + TD=(TMAX-TMIN)/(NTEMPS-1) + IF (TBAR .LT. TMIN) TBAR=TMIN + IF (TBAR .GT. TMAX) TBAR=TMAX + DO 100 I=1,NTEMPS + T=TMIN + (I-1)*TD + IF (TBAR .GT. T) GO TO 100 + FACTOR= (T-TBAR)/TD + PNN= PIANN(K,I) - FACTOR*(PIANN(K,I)-PIANN(K,I-1)) + PCC= PIACC(K,I) - FACTOR*(PIACC(K,I)-PIACC(K,I-1)) + PCN= PIACN(K,I) - FACTOR*(PIACN(K,I)-PIACN(K,I-1)) + PHN= PIAHN(K,I) - FACTOR*(PIAHN(K,I)-PIAHN(K,I-1)) + RETURN + 100 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/piach4.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/piach4.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/piach4.F (revision 1643) @@ -0,0 +1,81 @@ + SUBROUTINE PIACH4(NU,NT,XROT,XTRA,T) + IMPLICIT REAL (A-H,O-Z) + REAL NU,I10,NSQR,K + DIMENSION T(100) + DIMENSION FOX(60),XJ(23),G(23),E(23),WW(3,23),RHO(100,23), + $I10(100),XROT(100),XTRA(100) + + save ww,a2,pi,c,hck,tau1,tau2,cg,rho,c1,k,asqr,quads1,i10,xj + + DATA FOX /1.00,1.00,4.12,1.00,0.52,0.81,1.00,0.70,0.75,0.80, + $0.69,1.24,0.44,1.29,1.05,0.56,0.79,0.79,0.89,1.16,1.27,0.86, + $0.95,1.00,0.72,1.16,0.92,1.00,0.92,1.18,0.90,1.18,1.09,0.85, + $0.96,0.93,0.82,1.18,1.17,0.95,0.96,1.00,0.85,1.06,0.90,15*1.00/ + DATA JMAX1/20/,JMAX2/23/,PI/3.141592654/,H/1.05459E-27/, + $C/2.997925E10/,K /1.38054E-16/,HCK/1.43892/,XNLOS/2.687E19/, 276. + $ASQR/6.7081/,EPSK/148.6/,B/5.25/,ANORM/4.797E17/ + DO 8 IT=1,NT + X=4.*EPSK/T(IT) + I10(IT)=FI10(X) + 8 CONTINUE + DO 10 J=1,JMAX2 + XJ(J)=FLOAT(J-1) + E(J)=B*XJ(J)*(XJ(J)+1.) + 10 CONTINUE + G(1)=5. + G(2)=3. + G(3)=5. + G(4)=11. + G(5)=13. + G(6)=11. +!!! correction au nez + DO 15 J=7,JMAX2 + 15 G(J)=G(J-6)+16. + DO 20 J=1,JMAX1 + DO 20 I=1,3 + WW(I,J)=2.*PI*C*(E(J+I)-E(J)) + 20 CONTINUE + NSQR=(XNLOS*1.0E-24)**2 +c C1=64./63.*PI*PI*NSQR/H/C/ANORM + C1=64./63.*PI*PI*NSQR/H/C + QUADS1=11.10 + TAU1=9.00E-14 + TAU2=13.60E-14 + DO 90 IT=1,NT + SUM=0. + DO 50 J=1,JMAX2 + ARG=HCK*E(J)/T(IT) + RHO(IT,J)=EXP(-ARG) + SUM=SUM+(2.*XJ(J)+1.)*G(J)*RHO(IT,J) + 50 CONTINUE + DO 55 J=1,JMAX2 + RHO(IT,J)=RHO(IT,J)/SUM + 55 CONTINUE + 90 CONTINUE + RETURN + ENTRY OPACH4(NU,NT,XROT,XTRA,T) + W=2.*PI*C*NU + DO 200 IT=1,NT + XROT(IT)=0. + XTRA(IT)=0. + CZ=HCK*NU/T(IT) + CW=W*(1.-EXP(-CZ)) + DO 125 J=1,JMAX1 + XTRA(IT)=XTRA(IT)+(2.*XJ(J)+1.)*(2.*XJ(J)+1.)* + $ RHO(IT,J)*GAMMB(W,T(IT),TAU1,TAU2) +!!! avant cette boucle contenait K au lieu de IK en contradiction +!!! avec K Boltzman + DO 25 I=1,3 + IK=3*(J-1)+I + XROT(IT)=XROT(IT)+FOX(IK)*(2.*XJ(J)+1.)*(2.*XJ(J+I)+1.)* + $(RHO(IT,J )*GAMMB(W-WW(I,J),T(IT),TAU1,TAU2) + $+RHO(IT,J+I)*GAMMB(W+WW(I,J),T(IT),TAU1,TAU2)) + 25 CONTINUE + 125 CONTINUE +c COEF=CW*C1*IK*ASQR*QUADS1*I10(IT) + COEF=CW*C1*K*ASQR*QUADS1*I10(IT) + XROT(IT)=XROT(IT)*COEF + XTRA(IT)=XTRA(IT)*COEF + 200 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/piah2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/piah2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/piah2.F (revision 1643) @@ -0,0 +1,210 @@ + SUBROUTINE PIAH2(NU,NT,XROT,XTRA,T) +C +C XKH2 IS CALLED BY TH2HE TO COMPUT XK1, A FACTOR IN THE +C H2-H2 COLLISION-INDUCED ABSORPTION. +C +C THIS VERSION INCLUDES RESULTS OF RECENT LOW-TEMPERATURE FITS +C BY G. BIRNBAUM ET AL (NBS), AS IMPLEMENTED BY VIRGIL KUNDE +C AND GORDON BJORAKER, AUGUST 1982. +C +C THIS VERSION ALLOWS FOR A NON-EQUILIBRIUM PARA-HYDROGEN FRACTION. +C +C LAST CHANGED BY JOHN HORNSTEIN CSC FEB 28,1983 +C THIS CHANGE DELETED THE DOUBLE-TRANSITIONS, WHICH HAD BEEN +C INCORRECTLY FORMULATED IN BACHET ET AL. THE DELETION IS BY +C COMMENTING OUT WITH A "CD". +C +C THREE PARAMETERS ARE USED TO FIT THE H2-H2 OPACITY FROM +C 0 TO 2000 CM-1: STREN, TAU1, & TAU2. THE TEMPERATURE +C DEPENDENCE OF EACH PARAMETER IS HANDLED DIFFERENTLY. +C STREN WAS FIT TO EXPERIMENTAL VALUES IN DORE ET AL AND +C BACHET ET AL (1982) USING A LINEAR TEMPERATURE RELATION. +C TAU1 & TAU2 FOLLOW A POWER LAW OF THE FORM +C TAU = TAU0 * (T/T0)**BT AS SUGGESTED BY DORE ET AL. +C CONSTANTS FOR TAU1 ARE FROM DORE ET AL +C TAU2 = 1.23 * (TAU2 EVALUATED USING DORE POWER LAW). THIS MATCHES +C BACHET ET AL VALUES AT 195K & 297K (TAIL WT SINGLE + +C DOUBLE TRANSITION COEFFICIENTS). +C +C PARAMETER DESCRIPTION +C +C STRENGTH PARAMETER: STREN (SEE BACHET ET AL EQUATION 4B) +C STREN IS REALLY S/KB, TO AVOID LARGE POWERS OF 10. +C +C STREN = 6 * * OMEGA**2 * I8(R/SIGMA) / K +C (UNITS: KELVIN*ANGSTROM**6) +C +C IS MEAN SQUARE POLARIZABILITY UNIT: ANGSTROM**6 +C OMEGA IS QUADRUPOLE MOMENT UNIT: ESU*CM**2 +C R IS DISTANCE, SIGMA IS MOLECULAR SEPARATION, X = R/SIGMA +C I8(X) = 4*PI*INT(X**-8*EXP(-4.*E/(K*T)*(X**-12-X**-6))*X**2*DX) 00040000 +C E & SIGMA ARE PARAMETERS OF LENNARD-JONES INTERMOLECULAR POTENTIAL +C INT(...DX) IS INTEGRAL 0 TO INFINITY +C +C TIME PARAMETERS: TAU1 & TAU2 +C +C TAU1 CONTROLS HALF WIDTH NEAR LINE CENTER +C TAU2 CONTROLS EXPONENTIAL DECAY OF WINGS +C +C +C DOUBLE TRANSITIONS ARE INCLUDED. +C THE ABSORPTION DUE TO DOUBLE TRANSITIONS IS PROPORTIONAL TO C2 +C C2 = 4./45. * KAPPA**2 +C KAPPA = (APL-APP)/(1./3. * (APL+2.*APP)) +C APL & APP ARE POLARIZABILITIES PARALLEL +C AND PERPENDICULAR TO INTERNUCLEAR AXIS +C KAPPA = .375 FOR GROUND VIB STATE & J=0,1 OR 2 SEE KOLOS & WOLNIEWICZ +C JOURNAL OF CHEMICAL PHYSICS 46, 1426 (1967) TABLE 3 + IMPLICIT REAL (A-H,O-Z) + REAL NU,NSQR,K + LOGICAL ILIST + DIMENSION XROT(251),XTRA(251),XJ(10),G(10),A2(250),RHO(250,10), + A E(10),WN(10),WW(10),CG(10),BH(250),STREN(250),TAU1R(250), + B TAU2R(250),TAU1T(250),TAU2T(250),COREG0(2),COREG(10,2) + DIMENSION T(251) + DATA JMAX1/8/,JMAX2/10/, + . PI/3.141593/,HBAR/1.05450E-27/,C/2.997925E+10/,K/1.38054E-16/, + . HCK/1.43879/,XNLOS/2.687E19/,S0/178./,DSDT/.4091/, + . TAU1R0/7.25/,TAU2R0/3.45/,TAU1T0/7.25/,TAU2T0/3.45/, + . BT1/-.605/,BT2/-.607/,T0/273.15/,C2/0.0125/ +C + DIMENSION FPARA(99) + save pi,c,a2,ww,tau1t,tau2t,coreg0,rho,tau1r,tau2r,c1,k,bh,stren + save cg,coreg +C +C********************************************************************** +C +C +C G(J) ARE STATISTICAL WTS: +C G(J)=1 EVEN ROTATIONAL STATES, +C G(J)=3 ODD ROTATIONAL STATES. + ILIST=.FALSE. +C SET THE ORTHO/PARA TO EQUILIBRIUM -CPM + NPARA=-1. + DO 10 J = 1,JMAX2 + COREG(J,1)=1. + COREG(J,2)=0. + XJ(J) = FLOAT(J-1) + G(J) = 1.0 + IF (MOD(J,2) .EQ. 0) G(J) = 3.0 + 10 E(J) = H2ENER(0.0,XJ(J)) +C ****************** WARNING *********************** +C CHANGE MADE BY REGIS COURTIN (APRIL 1986). +C THE FOLLOWING COEFFICIENTS ARE INTRODUCED FOR THE CASE +C OF COLLISIONS BETWEEN H2 AND N2 MOLECULES. +C THE CORRECTED ABSORPTION COEFFICIENTS FIT THE DATA OF +C DORE ET AL (1986), PREPRINT. +C ****************************************************** + COREG0(1)=22.35 + COREG0(2)=-0.56 + COREG(1,1)=0.36 + COREG(1,2)=0.18 + COREG(2,1)=10.91 + COREG(2,2)=-0.433 +C ****************************************************** +C CG(J) = (2*J+1) * (CLEBSCH-GORDAN COEFF )**2 + DO 20 J = 1,JMAX1 + CG(J) = (2.0*XJ(J)+1.0) * (3.0*(XJ(J)+1.0)*(XJ(J)+2.0)) / + . (2.0*(2.0*XJ(J)+1.0)*(2.0*XJ(J)+3.0)) + WN(J) = E(J+2) - E(J) + 20 WW(J) = 2.0 * PI * C * WN(J) + NSQR = (XNLOS*1.0E-24)**2 + C1 = 2. * PI**2 * NSQR/(3. * HBAR * C) +C LIST HEADING FOR ORTHO AND PARA PROFILES: + IF ( (NPARA .LE. 0) .OR. (.NOT. ILIST)) GO TO 7000 + WRITE(6,5000) +5000 FORMAT(//,' EQUILIBRIUM AND ACTUAL FRACTIONS OF PARA-', + . ' AND ORTHO-HYDROGEN:',/,' LAYER',7X,'FPARA(EQU)', + . 7X,'FPARA(HERE)',7X,'FORTHO(EQU)',7X,'FORTHO(HERE)') +7000 DO 90 IT = 1,NT + BH(IT) = HBAR / (K*T(IT)) +C EVALUATE STREN, TAU1R, TAU2R AT DESIRED T + STREN(IT) = (S0 + DSDT*T(IT)) + TAU1R(IT) = TAU1R0 * (T(IT)/T0)**BT1 * 1.0E-14 + TAU2R(IT) = TAU2R0 * (T(IT)/T0)**BT2 * 1.0E-14 + TAU1T(IT) = TAU1T0 * (T(IT)/T0)**BT1 * 1.0E-14 + TAU2T(IT) = TAU2T0 * (T(IT)/T0)**BT2 * 1.0E-14 +C COMPUTE THE FULL PARTION FUNCTION Z, USED IN EQUILIBRIUM, +C WHERE ORTHO AND PARA ARE CONVENIENTLY TREATED AS DIFFERENT +C STATES OF THE SAME SPECIES. + Z = 0.0 + DO 50 J = 1,JMAX2 + RHO(IT,J) = EXP(-1.*HCK*E(J)/T(IT)) + 50 Z = Z + (2.0*XJ(J)+1.0)*G(J)*RHO(IT,J) + IF (NPARA .LE. 0) GO TO 54 +C COMPUTE THE PARTITION FUNCTIONS ZPARA AND ZORTHO USED FOR +C NON-EQUILIBRIUM RATIOS, WHERE IT IS CONVENIENT TO TREAT +C ORTHO AND PARA AS DISTINCT SPECIES. THE NUCLEAR SPIN +C FACTORS G(J) CANCEL OUT IN THIS CASE. + ZPARA = 0. + ZORTHO = 0. + DO 1000 J=1,JMAX2,2 + ZPARA = ZPARA + (2.*XJ(J) + 1.)*RHO(IT,J) + JJ = J + 1 +1000 ZORTHO = ZORTHO + (2.*XJ(JJ) + 1.)*RHO(IT,JJ) +C COMPUTE AND LIST THE EQUILIBRIUM AND ACTUAL PROFILES: + FEPARA = ZPARA/Z + FEORTH = 3.*ZORTHO/Z + FORTHO = 1. - FPARA(IT) + IF (ILIST) WRITE(6,2000) IT, FEPARA, FPARA(IT), FEORTH, FORTHO +2000 FORMAT(' ',I4,2F15.5,10X,2F15.5) +C FORM A NEW RHO WHICH EQUALS RHO(PARA) WHEN XJ IS EVEN +C (INDEX J IS ODD) AND EQUALS RHO(ORTHO) WHEN XJ IS ODD. + DO 3000 J=1,JMAX2,2 + RHO(IT,J) = FPARA(IT)*RHO(IT,J)/ZPARA + JJ = J + 1 +3000 RHO(IT,JJ) = FORTHO*RHO(IT,JJ)/ZORTHO + GO TO 57 +C EQUILIBRIUM HYDROGEN STATISTICAL WEIGHTS +54 DO 55 J = 1,JMAX2 +55 RHO(IT,J) = G(J)*RHO(IT,J) / Z +57 A2(IT) = 0.0 + DO 60 J = 1,JMAX1 +60 A2(IT) = A2(IT) + XJ(J)*(XJ(J)+1.0)*(2.0*XJ(J)+1.0)*RHO(IT,J)/ + . ((2.0*XJ(J)-1.0)*(2.0*XJ(J)+3.0)) + 90 CONTINUE + RETURN + ENTRY OPAH2(NU,NT,XROT,XTRA,T) + W = 2.0 * PI * C * NU + DO 200 IT = 1,NT + DBL = 0. + FR = 0. +C EVALUATE TRANSLATIONAL PART OF SHAPE FACTOR F + FT = A2(IT) * GAMFCN(W,T(IT),TAU1T(IT),TAU2T(IT)) + .* COREG0(1)*T(IT)**COREG0(2) + DO 125 J = 1,JMAX1 +C EVALUATE THE ROTATIONAL PART OF F + FR = FR + CG(J) * (RHO(IT,J)*GAMFCN(W-WW(J),T(IT),TAU1R(IT), + . TAU2R(IT))+RHO(IT,J+2)*GAMFCN(W+WW(J),T(IT),TAU1R(IT), + . TAU2R(IT))) + . * COREG(J,1)*T(IT)**COREG(J,2) +C DBL = DBL + CG(J) * (RHO(IT,J) + RHO(IT,J+2)) + 125 CONTINUE +C ADD ON PART OF DOUBLE TRANSITION OPACITY (BACHET ET AL EQN 11) +CD FR = FR * (1.0 + C2 * A2(IT)) +C MORE DOUBLE TRANS (BACHET ET AL EQN 12) +CD FT = FT * (1.0 + C2 * A2(IT)) +C AND STILL MORE DOUBLE TRANS (BACHET ET AL EQN 13) +CD FT = FT + C2 * DBL*DBL*GAMFCN(W,T(IT),TAU1T(IT),TAU2T(IT)) + F = FT + FR +C EVALUATE & ADD ON DOUBLE TRANSITIONS (BACHET ET AL EQN 14) +CD DO 130 J1=1,4 +CD DO 130 J2=1,4 +CD IF (J1.NE.(J1+2).OR.J2.NE.(J1+2)) +CD A F = F + C2*RHO(IT,J1)*CG(J1)*RHO(IT,J2)*CG(J2) +CD B * GAMFCN(W-WW(J1)-WW(J2),T(IT),TAU1R(IT),TAU2R(IT)) +CD IF ((J1+2).NE.(J2+2).OR.J2.NE.J1) +CD A F = F + C2*RHO(IT,J1+2)*CG(J1)*RHO(IT,J2)*CG(J2) +CD B * GAMFCN(W+WW(J1)-WW(J2),T(IT),TAU1R(IT),TAU2R(IT)) +CD IF ((J1+2).NE.J2.OR.(J2+2).NE.J1) +CD A F = F + C2*RHO(IT,J1+2)*CG(J1)*RHO(IT,J2+2)*CG(J2) +CD B * GAMFCN(W+WW(J1)+WW(J2),T(IT),TAU1R(IT),TAU2R(IT)) +CD IF (J1.NE.J2.OR.(J2+2).NE.(J1+2)) +CD A F = F + C2*RHO(IT,J1)*CG(J1)*RHO(IT,J2+2)*CG(J2) +CD B * GAMFCN(W-WW(J1)+WW(J2),T(IT),TAU1R(IT),TAU2R(IT) +CD130 CONTINUE + XROT(IT) = C1 * K * W * (1.0-EXP(-BH(IT)*W)) * STREN(IT)*FR + XTRA(IT) = XROT(IT)*FT/FR +200 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/pian2.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/pian2.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/pian2.F (revision 1643) @@ -0,0 +1,83 @@ + SUBROUTINE PIAN2(NU,NT,XROT,XTRA,T) +C +C THIS ROUTINE WAS FIRST WRITTEN BY REGIS COURTIN IN 1980 : +C THE PARAMETERS WERE DETERMINED BY THE MEASUREMENTS OF +C BUONTEMPO ET AL (1975), JOURNAL OF CHEMICAL PHYSICS 63, 2570. +C LAST MODIFIED BY REGIS COURTIN (APRIL 23,1986) : +C THE QUADS1 PARAMETER WAS ADJUSTED TO FIT THE MEASUREMENTS OF +C DAGG ET AL (1985), CANADIAN JOURNAL OF PHYSICS 63, 625. +C + IMPLICIT REAL (A-H,O-Z) + REAL NU,I8,NSQR,K + real c + DIMENSION T(100) + DIMENSION XROT(100),XTRA(100) + DIMENSION XJ(32),G(32),E(32),WW(32),CG(32),RHO(100,32), + $I8(100),QUADS1(100),TAU1(100),TAU2(100),A2(100) + save ww,a2,pi,c,hck,tau1,tau2,cg,rho,c1,k,asqr,quads1,i8 + DATA JMAX1/30/,JMAX2/32/,PI/3.141592654/,H/1.05459E-27/, + $C/2.997925E10/,K/1.38054E-16/,HCK/1.43892/,XNLOS/2.687E19/, + $ASQR/3.3124/,EPSK/71.4/,PW1/.639/,PW2/.423/, + $DSDT/-.0204/ + DO 8 IT=1,NT + X=4.*EPSK/T(IT) + I8(IT)=FI8(X) + 8 CONTINUE + DO 10 J=1,JMAX2 + XJ(J)=FLOAT(J-1) + G(J)=6. + IF (MOD(J,2).EQ.0) G(J)=3. + E(J)=AZENER(0.,XJ(J)) + 10 CONTINUE + DO 20 J=1,JMAX1 + CG(J)=1.5*(XJ(J)+1.)*(XJ(J)+2.)/(2.*XJ(J)+3.) + WW(J)=2.*PI*C*(E(J+2)-E(J)) + 20 CONTINUE + NSQR=(XNLOS*1.0E-24)**2 + C1=4.*PI*PI*NSQR/H/C + DO 90 IT=1,NT + QUADS1(IT)=27.72+DSDT*T(IT) + TAU1(IT)=9.797E-12/(T(IT)**PW1) + TAU2(IT)=1.518E-12/(T(IT)**PW2) + SUM=0. + DO 50 J=1,JMAX2 + ARG=HCK*E(J)/T(IT) + RHO(IT,J)=EXP(-ARG) + SUM=SUM+(2.*XJ(J)+1.)*G(J)*RHO(IT,J) + 50 CONTINUE + DO 55 J=1,JMAX2 + RHO(IT,J)=G(J)*RHO(IT,J)/SUM + 55 CONTINUE + A2(IT)=0. + DO 60 J=1,JMAX1 + A2(IT)=A2(IT)+XJ(J)*(XJ(J)+1.)*(2.*XJ(J)+1.)*RHO(IT,J)/ + $ ((2.*XJ(J)-1.)*(2.*XJ(J)+3.)) + 60 CONTINUE + 90 CONTINUE +c print*,'A2 dans pia...',a2 +c print*,'var dans pia...', +c s pi,c,hck,tau1,tau2,cg,rho,c1,k,asqr,quads1,i8 + + RETURN +c!!!! ENTRY OPAN2(NU,NT,XROT,XTRA) + ENTRY OPAN2(NU,NT,XROT,XTRA,T) +c print*,'A2 dans opa...',a2 +c print*,'var dans opa...', +c s pi,c,hck,tau1,tau2,cg,rho,c1,k,asqr,quads1,i8 + W=2.*PI*C*NU + DO 200 IT=1,NT + CZ=HCK*NU/T(IT) + CW=W*(1.-EXP(-CZ)) + XTRA(IT)=A2(IT)*GAMMB(W,T(IT),TAU1(IT),TAU2(IT)) + XROT(IT)=0. + DO 125 J=1,JMAX1 + XROT(IT)=XROT(IT)+CG(J)* + $(RHO(IT,J )*GAMMB(W-WW(J),T(IT),TAU1(IT),TAU2(IT)) + $+RHO(IT,J+2)*GAMMB(W+WW(J),T(IT),TAU1(IT),TAU2(IT))) + 125 CONTINUE + COEF=CW*C1*K*ASQR*QUADS1(IT)*I8(IT) + XROT(IT)=XROT(IT)*COEF + XTRA(IT)=XTRA(IT)*COEF + 200 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/printflag.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/printflag.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/printflag.F (revision 1643) @@ -0,0 +1,186 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/printflag.F,v 1.1.1.1 2004/05/19 12:53:09 lmdzadmin Exp $ +! + SUBROUTINE printflag( ok_mensuel, ok_journe, ok_instan ) +c + +c +c Auteur : P. Le Van + + IMPLICIT NONE + + LOGICAL cycle_diurn0,soil_model0,ok_orodr0 + LOGICAL ok_orolf0,ok_gw_nonoro0 + LOGICAL ok_mensuel, ok_journe, ok_instan + INTEGER radpas0 + INTEGER chimpas0 +c +#include "clesphys.h" +#include "tabcontrol.h" +#include "YOMCST.h" +c +c + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT *,' ******** Choix des principales cles de la physique + , *********' + PRINT *,' ******************************************************* + ,************' + PRINT 100 + PRINT 10, cycle_diurne, soil_model + PRINT 100 + + PRINT 11, ok_orodr, ok_orolf, ok_gw_nonoro + PRINT 100 + + PRINT 12, nbapp_rad + PRINT 100 + + PRINT 8, radpas + PRINT 100 + + PRINT 23, nbapp_chim + PRINT 100 + + PRINT 24, chimpas + PRINT 100 + + PRINT 4,ok_mensuel, ok_journe, ok_instan + PRINT 100 + PRINT 100 +c +c + cycle_diurn0 = .FALSE. + soil_model0 = .FALSE. + ok_orodr0 = .FALSE. + ok_orolf0 = .FALSE. + ok_gw_nonoro0 = .FALSE. + + IF( tabcntr0( 7 ).EQ. 1. ) cycle_diurn0 = .TRUE. + IF( tabcntr0( 8 ).EQ. 1. ) soil_model0 = .TRUE. + IF( tabcntr0(10 ).EQ. 1. ) ok_orodr0 = .TRUE. + IF( tabcntr0(11 ).EQ. 1. ) ok_orolf0 = .TRUE. + IF( tabcntr0(12 ).EQ. 1. ) ok_gw_nonoro0 = .TRUE. + + PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + ,$$$$$$$$$$$$$' + PRINT 100 +c + + IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad ) THEN + PRINT 21, INT(tabcntr0(6)), nbapp_rad + if (INT(tabcntr0( 6 )).ne.0) then + radpas0 = NINT( RDAY/tabcntr0(1)/INT( tabcntr0(6) ) ) + else + radpas0 = 9999 + endif + PRINT 100 + PRINT 22, radpas0, radpas + PRINT 100 + ENDIF + + IF( INT( tabcntr0( 16 ) ) .NE. nbapp_chim ) THEN + PRINT 25, INT(tabcntr0(16)), nbapp_chim + if (INT(tabcntr0(16)).ne.0) then + chimpas0 = NINT( RDAY/tabcntr0(1)/INT( tabcntr0(16) ) ) + else + chimpas0 = 9999 + endif + PRINT 100 + PRINT 26, chimpas0, chimpas + PRINT 100 + ENDIF + + IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND. + , cycle_diurne ) THEN + PRINT 13, cycle_diurn0, cycle_diurne + PRINT 100 + ENDIF + + IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND. + , soil_model ) THEN + PRINT 14, soil_model0, soil_model + PRINT 100 + ENDIF + + IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND. + , ok_orodr ) THEN + PRINT 15, ok_orodr0, ok_orodr + PRINT 100 + ENDIF + + IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND. + , ok_orolf ) THEN + PRINT 17, ok_orolf0, ok_orolf + PRINT 100 + ENDIF + + IF( ok_gw_nonoro0.AND..NOT.ok_gw_nonoro.OR..NOT.ok_gw_nonoro0. + , AND.ok_gw_nonoro ) THEN + PRINT 18, ok_gw_nonoro0, ok_gw_nonoro + PRINT 100 + ENDIF + + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT 100 + + 4 FORMAT(2x,5(1H*),' ok_mensuel = ',l3,2x,' ok_journe = ',l3,2x,' + . , ok_instan = ',l3,8x,5(1H*) ) + + 8 FORMAT(2x,'***** radpas = ' , + , i4,6x,' *****') + + 10 FORMAT(2x,5(1H*),' Cycle_diurne = ',l3,4x,', Soil_model = ', + , l3,12x,6(1H*) ) + + + 11 FORMAT(2x,5(1H*),', Ok_orodr = ',l3,3x,', Ok_orolf = ',l3,3x, + , ' ok_gw_nonoro = ',l3,3x,5(1H*) ) + + + 12 FORMAT(2x,'***** Nb d appels /jour des routines de rayonn. = ' , + , i4,6x,' *****') + + 13 FORMAT(2x,'$$$$$$$$ Attention !! cycle_diurne different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 14 FORMAT(2x,'$$$$$$$$ Attention !! soil_model different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 15 FORMAT(2x,'$$$$$$$$ Attention !! ok_orodr different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 17 FORMAT(2x,'$$$$$$$$ Attention !! ok_orolf different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 18 FORMAT(2x,'$$$$$$$$ Attention !! ok_gw_nonoro different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 20 FORMAT(/2x,'$$$$$$$$ Attention !! iflag_con different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 21 FORMAT(2x,'$$$$$$$$ Attention !! nbapp_rad different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 22 FORMAT(2x,'$$$$$$$$ Attention !! radpas different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 23 FORMAT(2x,'***** Nb d appels /jour des routines de chimie = ' , + , i4,6x,' *****') + + 24 FORMAT(2x,'***** chimpas = ' , + , i4,6x,' *****') + + 25 FORMAT(2x,'$$$$$$$$ Attention !! nbapp_chim different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 26 FORMAT(2x,'$$$$$$$$ Attention !! chimpas different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 100 FORMAT(/) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/profile.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/profile.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/profile.F (revision 1643) @@ -0,0 +1,209 @@ + SUBROUTINE profile(unit,nlev,dzst,pres,temp) + IMPLICIT NONE +c======================================================================= +c Subroutine utilisee dans le modele 1-D "rcm1d" +c pour l'initialisation du profil atmospherique +c======================================================================= +c +c VERSION VENUS +c +c differents profils d'atmospheres. T=f(z) +c entree: +c unit unite de lecture de "rcm1d.def" +c nlev nombre de niveaux (nlev=llm+1, surf + couches 1 a llm) +c dzst dz/T (avec dz = epaisseur de la couche en m) +c pres pressure profile +c ichoice choix de l'atmosphere: +c 1 Temperature constante +c 2 profil Huygens lisse +c 3 +c 4 +c 5 +c 6 T constante + perturbation gauss (level) (christophe 10/98) +c 7 T constante + perturbation gauss (km) (christophe 10/98) +c 8 Lecture du profile dans un fichier ASCII (profile) +c tref temperature de reference +c isin ajout d'une perturbation (isin=1) +c pic pic perturbation gauss pour ichoice = 6 ou 7 +c largeur largeur de la perturbation gauss pour ichoice = 6 ou 7 +c hauteur hauteur de la perturbation gauss pour ichoice = 6 ou 7 +c +c sortie: +c temp temperatures en K +c +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + +c arguments: +c ---------- + + INTEGER nlev, unit + REAL dzst(nlev),pres(nlev),temp(nlev) + +c local: +c ------ + + INTEGER il,ichoice,isin,iter + REAL pi + REAL tref,t1,t2,t3,ww + REAL pic,largeur + REAL hauteur,tmp + REAL zkm(nlev) ! altitude en km + real a1,b1,c1,a2,b2,c2 + + isin = 0 + +c----------------------------------------------------------------------- +c choix du profil: +c ---------------- + +c la lecture se fait dans le rcm1d.def, ouvert par rcm1d.F + READ(unit,*) + READ(unit,*) + READ(unit,*) + READ(unit,*) ichoice + READ(unit,*) tref + READ(unit,*) isin + READ(unit,*) pic + READ(unit,*) largeur + READ(unit,*) hauteur + +c----------------------------------------------------------------------- +c ichoice=1 temperature constante: +c -------------------------------- + + IF(ichoice.EQ.1) THEN + temp(1) = tref + zkm(1) = 0.0 + DO il=2,nlev + temp(il)= tref + zkm(il) = zkm(il-1)+temp(il)*dzst(il)/1000. + ENDDO + +c----------------------------------------------------------------------- +c ichoice=2 Huygens lisse: +c ------------------------ + + ELSE IF(ichoice.EQ.2) THEN + a1 = 142.1 + b1 = -21.45 + c1 = 40.11 + a2 = 106.3 + b2 = 3183. + c2 = 4737. +c pres est en Pa => conversion car expression veut p en hPa + DO il=1,nlev + temp(il)=a1*exp(-((pres(il)/100.-b1)/c1)**2.) + . + a2*exp(-((pres(il)/100.-b2)/c2)**2.) + ENDDO + zkm(1) = 0.0 + DO il=2,nlev + zkm(il) = zkm(il-1)+(temp(il-1)+temp(il))/2.*dzst(il)/1000. + ENDDO + +c----------------------------------------------------------------------- +c ichoice=3 +c ---------------------------- + + ELSE IF(ichoice.EQ.3) THEN + print*,"Profil T a faire..." + stop + +c----------------------------------------------------------------------- +c ichoice=4 : +c ------------------ + + ELSE IF(ichoice.EQ.4) THEN + print*,"Cas non defini..." + print*,"Stop dans profile.F" + STOP + +c----------------------------------------------------------------------- +c ichoice=5 : +c ---------------- + + ELSE IF(ichoice.EQ.5) THEN + print*,"Cas non defini..." + print*,"Stop dans profile.F" + STOP + +c----------------------------------------------------------------------- +c ichoice=6 +c --------- + + ELSE IF(ichoice.EQ.6) THEN + temp(1) = tref + zkm(1) = 0.0 + DO il=2,nlev + tmp=il-pic + temp(il)= tref + hauteur*exp(-tmp*tmp/largeur/largeur) + zkm(il) = zkm(il-1)+temp(il)*dzst(il)/1000. + ENDDO + + +c----------------------------------------------------------------------- +c ichoice=7 +c --------- + + ELSE IF(ichoice.EQ.7) THEN + temp(1) = tref + zkm(1) = 0.0 + DO il=2,nlev + zkm(il) = zkm(il-1)+tref*dzst(il)/1000. ! approx + tmp=zkm(il)-pic + temp(il)= tref + hauteur*exp(-tmp*tmp*4/largeur/largeur) + zkm(il) = zkm(il-1)+(temp(il-1)+temp(il))/2.*dzst(il)/1000. + ENDDO + +c----------------------------------------------------------------------- +c ichoice=8 +c --------- + + ELSE IF(ichoice.GE.8) THEN + OPEN(11,file='profile',status='old',form='formatted',err=101) + DO il=1,nlev + READ (11,*) temp(il) + ENDDO + zkm(1) = 0.0 + DO il=2,nlev + zkm(il) = zkm(il-1)+(temp(il-1)+temp(il))/2.*dzst(il)/1000. + ENDDO + + GOTO 201 +101 STOP'fichier profile inexistant' +201 CONTINUE + CLOSE(10) + +c----------------------------------------------------------------------- + + ENDIF + +c----------------------------------------------------------------------- +c rajout eventuel d'une perturbation: +c ----------------------------------- + + IF(isin.EQ.1) THEN + pi=2.*ASIN(1.) + DO il=1,nlev + temp(il)=temp(il)+(1.-1000./(1000+zkm(il)*zkm(il)))*( + s 6.*SIN(zkm(il)*pi/6.)+9.*SIN(zkm(il)*pi/10.3) ) + ENDDO + ENDIF + + +c----------------------------------------------------------------------- +c Ecriture du profil de temperature dans un fichier profile.out +c ------------------------------------------------------------- + + +c OPEN(12,file='profile.out') +c DO il=1,nlev +c write(12,*) temp(il) +c write(12,*) temp(il),zkm(il) +c ENDDO +c CLOSE(12) + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/radlwsw.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/radlwsw.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/radlwsw.F (revision 1643) @@ -0,0 +1,203 @@ + SUBROUTINE radlwsw(dist, rmu0, fract, zzlev, + . paprs, pplay,tsol, pt, nq, nmicro, pq,qaer) +c +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719 +c Objet: interface entre le modele et les rayonnements +c Arguments: +c dist-----input-R- distance astronomique terre-soleil +c rmu0-----input-R- cosinus de l'angle zenithal +c fract----input-R- duree d'ensoleillement normalisee +c falbe----input-R- surface albedo +c zzlev----input-R- altitudes des inter-couches (m) +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c tsol-----input-R- temperature du sol (en K) +c t--------input-R- temperature (K) +c nq-------input-R- nombre de traceurs +c nmicro---input-R- nombre de traceurs microphysiques +c pq-------input-R- traceurs (rapports de melange) +c heat-----output-R- echauffement atmospherique (visible) (K/s) +c cool-----output-R- refroidissement dans l'IR (K/s) +c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas) +c topsw----output-R- flux solaire net au sommet de l'atm. (+ vers le bas) +c toplw----output-R- ray. IR net au sommet de l'atmosphere (+ vers le haut) +c solsw----output-R- flux solaire net a la surface (+ vers le bas) +c sollw----output-R- ray. IR net a la surface (+ vers le bas) +c sollwdown-output-R- ray. IR descendant a la surface (+ vers le bas) +c lwnet____output-R- flux IR net (+ vers le haut) +c swnet____output-R- flux solaire net (+ vers le bas) +c + +c S. Lebonnois 05/2008 +c VERSION TITAN + +c====================================================================== + use dimphy + USE phys_state_var_mod, only: falbe,heat,cool,radsol, + . topsw,toplw,solsw,sollw,sollwdown,lwnet,swnet, + . lwup,lwdn,swup,swdn + USE write_field_phy + IMPLICIT none +#include "YOMCST.h" +#include "clesphys.h" +c +c ARGUMENTS + INTEGER nq,nmicro + real rmu0(klon), fract(klon), dist +c + real zzlev(klon,klev+1),paprs(klon,klev+1), pplay(klon,klev) + real tsol(klon) + real pt(klon,klev) + real pq(klon,klev,nq) + REAL qaer(klon,klev,nq) +c +c LOCAL VARIABLES + integer i,k,l,iq + real zp(klon,klev+1),zt(klon,klev+1),zz(klon,klev+1) + real zq(klon,klev,nq) + real zheatc(klon,klev), zcoolc(klon,klev) + real zheatp(klon,klev), zcoolp(klon,klev) + REAL zswupc(klon,klev+1),zlwupc(klon,klev+1) + REAL zswupp(klon,klev+1),zlwupp(klon,klev+1) + REAL zswdnc(klon,klev+1),zlwdnc(klon,klev+1) + REAL zswdnp(klon,klev+1),zlwdnp(klon,klev+1) + REAL zsollwdownc(klon),zsollwdownp(klon) + INTEGER icld + + +c ======================================= +c INITIALISATIONS +c ======================================= + +c passage au pressions en bar avec indice 1 au sommet. + do l=2,klev+1 + do i=1,klon + zp(i,l)=paprs(i,klev+2-l)*1.e-5 + enddo + enddo + do i=1,klon + zp(i,1)=zp(i,2)*.001 + enddo + +c call WriteField_phy('radlwsw_zp',zp,klev+1) + +c ======================================= +c altitudes (m) avec indice 1 en haut + do l=1,klev+1 + do i=1,klon + zz(i,l)=zzlev(i,klev+2-l) + enddo + enddo + +c temperatures avec indice 1 en haut + do l=1,klev + do i=1,klon + zt(i,l)=pt(i,klev+1-l) + enddo + enddo + do i=1,klon + zt(i,klev+1)=tsol(i) + enddo + +c traceurs avec indice 1 en haut + do l=1,klev + do i=1,klon + do iq=1,nq + zq(i,l,iq)=pq(i,klev+1-l,iq) + enddo + enddo + enddo + +c ======================================= +c CALCUL DES TAU V+IR (dans des common...) +c ======================================= + + print*,'On calcule les opacites' + + CALL radtitan(zp,nq,nmicro,zq,qaer) + +c CALCUL DU SW +c ======================================= + + print*,'On calcule le rayonnement SW' + + IF (clouds.eq.1) THEN + ICLD = 1 ! colonne avec nuages + CALL heating(dist,rmu0,fract,falbe,zheatc,zswupc,zswdnc,icld) + ELSE + zheatc = 0. + zswupc = 0. + zswdnc = 0. + ENDIF + ICLD = 0 ! colonne sans nuages + CALL heating(dist,rmu0,fract,falbe,zheatp,zswupp,zswdnp,icld) + +c inversion de l'axe vertical + do l=1,klev + do i=1,klon + heat(i,l)=zheatc(i,klev+1-l)*xnuf + + & zheatp(i,klev+1-l)*(1.-xnuf) + enddo + enddo + do l=1,klev+1 + do i=1,klon + swup(i,l) =zswupc(i,klev+2-l)*xnuf + + & zswupp(i,klev+2-l)*(1.-xnuf) + swdn(i,l) =zswdnc(i,klev+2-l)*xnuf + + & zswdnp(i,klev+2-l)*(1.-xnuf) + swnet(i,l)=swdn(i,l)-swup(i,l) + enddo + enddo + + solsw = swnet(:,1) + topsw = swnet(:,klev+1) + +c ======================================= +c CALCUL DU LW +c ======================================= + + print*,'On calcule le rayonnement LW' + + IF (clouds.eq.1) THEN + ICLD = 1 + CALL cooling(klon,klev+1,zp,zt,zz,zcoolc,zlwupc,zlwdnc, + & zsollwdownc,icld) + ELSE + zcoolc = 0. + zlwupc = 0. + zlwdnc = 0. + zsollwdownc = 0. + ENDIF + ICLD = 0 + CALL cooling(klon,klev+1,zp,zt,zz,zcoolp,zlwupp,zlwdnp, + & zsollwdownp,icld) + +c inversion de l'axe vertical + do l=1,klev + do i=1,klon + cool(i,l)=zcoolc(i,klev+1-l)*xnuf + + & zcoolp(i,klev+1-l)*(1.-xnuf) + enddo + enddo + do l=1,klev+1 + do i=1,klon + lwup(i,l) =zlwupc(i,klev+2-l)*xnuf + + & zlwupp(i,klev+2-l)*(1.-xnuf) + lwdn(i,l) =zlwdnc(i,klev+2-l)*xnuf + + & zlwdnp(i,klev+2-l)*(1.-xnuf) + lwnet(i,l)=lwup(i,l)-lwdn(i,l) + enddo + enddo + + do i=1,klon + sollwdown(i)=zsollwdownc(i)*xnuf + + & zsollwdownp(i)*(1.-xnuf) + enddo + + sollw = -lwnet(:,1) + toplw = lwnet(:,klev+1) + radsol = solsw+sollw + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/radtitan.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/radtitan.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/radtitan.F (revision 1643) @@ -0,0 +1,318 @@ + SUBROUTINE RADTITAN(p,nq,nmicro,ycomp,qaer) + +c======================================================================= +c +c Authors: C.P. Mc Kay 01/02/91 +c ------- +c +c Object: Computation of the solar and infra-red +c ------- Opacities (dans des common...) +c +c ON TITAN ADAPTED FROM BEST.FOR FEB 91 +c C.P. McKAY +c +c Arguments: +c ---------- +c +c Input: +c ------ +c +c p(klon,nl) pressure (level) +c nq nombre de traceurs +c nmicro nombre de traceurs microphysiques +c ycomp(klon,nlayer,nq) +c +c Output: +c ------- +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + + USE infotrac_phy, ONLY: tname + use dimphy + USE geometry_mod, ONLY: latitude ! in radians + USE optcld, only : iniqcld + use moyzon_mod, only:plevmoy + USE TGMDAT_MOD, ONLY: RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC, + & RCLOUD,FARGON + USE TGMDAT_MOD, ONLY: RHOP + IMPLICIT NONE +#include "dimensions.h" +#include "clesphys.h" +#include "microtab.h" +#include "numchimrad.h" +#include "YOMCST.h" + +c Pour le CRAY, les block data doivent etre declares external +c pour etre pris en compte + EXTERNAL TGMDAT + + INTEGER NLEVEL,NLAYER,NSPECI,NSPC1I,NSPECV,NSPC1V,NSPV + PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) + PARAMETER (NSPV=21) ! LDO POUR CALCUL ALBEDO + +c +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c + +c Arguments: +c ---------- + + INTEGER nq,nmicro + + REAL p(klon,nlevel) + REAL ycomp(klon,nlayer,nq) + REAL qaer(klon,klev,nq) + +c Local: +c ------ + + INTEGER I,J,IG,K,IPRINT + INTEGER IPREM + LOGICAL notfirstcall + SAVE IPREM,notfirstcall + data notfirstcall/.false./ + + REAL emu,somcoslat,coslat(ngrid) + + REAL PCH4, effg,FH2L,RHCH4L,SSUM ! effg est une fonction(z) + +c COMMONS for interface with local subroutines: +c --------------------------------------------- + + REAL DZED(NLAYER) + REAL Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) + REAL CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) + REAL XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) + REAL C2H2(NLAYER),C2H6(NLAYER),HCN(NLAYER) + + COMMON /VERTICAL/ DZED + + COMMON /ATM/ Z,PRESS + & ,DEN,TEMP + + + COMMON /GASS/ CH4,XN2 + & ,H2,AR + & ,XMU,GAS1 + & ,COLDEN + + COMMON /STRATO/ C2H2,C2H6 + COMMON /STRAT2/ HCN + +c----------------------------------------------------------------------- +c 1. Initialisations: +c ------------------- + + +C IPRINT CONTOLS OUTPUT AMOUNT:0=IRREDUCIBLE OUTPUT,LESS THAN 1 PAGE +C PER RUN, 0=MINIMAL OUTPUT, 1=BACKGROUND ATM AND SPEC; 10=FULL DEBUG + IPRINT=1 + +C&& + FHAZE=0.3 +C&& + if(iprem.eq.0) then + TAUFAC=0 +c xvis et xir lus dans physiq.def (ancien fichier initpar) + FHVIS= xvis + FHIR = xir +c on initialise le paquet optcld + if (clouds.eq.1) call iniqcld() + iprem=1 + endif + +c----------------------------------------------------------------------- +c 2. Calcul of the atmospheric profile: +c ------------------------------------- + + print*,'dans radtitan ',klon + print*,notfirstcall + IF(notfirstcall) GOTO 300 !F au premier appel! + print*,notfirstcall + +c pression moyenne globale +c passage au pressions en bar avec indice 1 au sommet. +c (similaire zp dans radlwsw) + DO 210 J=2,NLEVEL + PRESS(J)=plevmoy(NLEVEL+1-j)*1.e-5 +210 CONTINUE + PRESS(1) = PRESS(2)*0.001 + +c a cause du tableau predefini dans lell.F (et lell_light.F) +c IF(press(nlevel-1).GE.1.44) then + IF(press(nlevel-1).GE.1.48) then + STOP'pression au sol trop grande' + PRINT*,'pression au sol trop grande' + endif + +c PRESS(nlevel)=1.48 +c XCORR=1.48/PRESS(nlevel) +c DO 211 J=1,NLEVEL +c PRESS(J)=XCORR*PRESS(J) +c11 CONTINUE + +c ********************************************************* +c + 20/1/00: S.Lebonnois: model with chemistry +c ++ 22/07/02: ajout HCN ++ +c ********************************************************* + if (ylellouch) then +c------------------------------------------------------ +c initialisation de l'atmosphere et de la composition +c------------------------------------------------------ + CALL LELL(NLEVEL,Z,RHCH4L,FH2L,FARGON,TEMP,PRESS,DEN,XMU, + & CH4,H2,XN2,AR,IPRINT) + + print*,'LELLOUCH' + do i=1,55 + print*,z(i),PRESS(i) + enddo +C +C +C NOW CALCULATE THE LAYER AVERAGE GAS MIXING RATIOS. + CALL GASSES(IPRINT) + + else +c------------------------------------------------------ +c initialisation seulement de l'atmosphere +c------------------------------------------------------ + CALL LELL_LIGHT(NLEVEL,Z,FARGON,TEMP,PRESS,DEN,XMU, + & CH4,H2,XN2,AR,IPRINT) + + print*,'LELLOUCH LIGHT' + do i=1,55 + print*,z(i),PRESS(i) + enddo + +c ++ remplace gasses.F ++ + + do i=1,nq + if (tname(i).eq."CH4") then + iradch4=i + elseif (tname(i).eq."C2H2") then + iradc2h2=i + elseif (tname(i).eq."C2H6") then + iradc2h6=i + elseif (tname(i).eq."HCN") then + iradhcn=i + elseif (tname(i).eq."N2") then + iradn2=i + elseif (tname(i).eq."H2") then + iradh2=i + endif + enddo + +c print*,iradch4,iradc2h2,iradc2h6,iradhcn,iradn2,iradh2 + + print*,' ALT CH4 mass mixing ratio ' + + somcoslat=0. + do j=1,klon + coslat(j) = cos(latitude(j)) + somcoslat=somcoslat+coslat(j) + enddo + do i=1,nlayer +c attention ici, Z en km doit etre passe en m + colden(i)=rhop*(press(i+1)-press(i))/effg(z(i)*1000.) + gas1(i)=0. + emu=(xmu(i+1)+xmu(i))/2. + do j=1,klon + gas1(i) = gas1(i) + + $ coslat(j)/somcoslat*ycomp(j,i,iradch4)*(16./emu) + enddo + print*,z(i),gas1(i) + enddo + + RHCH4=0. + do j=1,klon + RHCH4 = RHCH4 + coslat(j)/somcoslat*ycomp(j,nlayer,iradch4) + enddo + RHCH4 = RHCH4*press(nlevel)/PCH4(temp(nlevel)) + print*,'RHCH4 = ',RHCH4 + + endif + +c ********************************************************* + +C +C CALL A ROUTINE THAT SETS UP THE IR SPECTRAL INTERVALS + CALL SETSPI(IPRINT) + CALL SETSPV(IPRINT) +C SET UP PIA COEFFICIENTS + CALL SETPIA(IPRINT,1) + + IF (TAUFAC .GT. 0.) CALL CLD(IPRINT) + +C +C CALL A SUBROUTINE THAT SETS UP THE OPTICAL PROPERTIES IN THE +C INFRARED. AND THEN IN THE VISIBLE. + +C NOW, THIS COMPUTATION IS DONE FOR EACH VALUE OF klon +C AND AT EACH CALL OF THE PHYSICS + + print*,'aerosol/gas/cloud properties' + + CALL OPTCI(ycomp,qaer,nmicro,IPRINT) ! #1 + print*,'On sort de optci' + +C NOW, THIS COMPUTATION IS DONE FOR EACH VALUE OF klon +C INFRARED. AND THEN IN THE VISIBLE. + + CALL OPTCV(qaer,nmicro,IPRINT) ! #2 + + do j=1,NLAYER + DZED(j)=Z(J)-Z(J+1) + enddo + +c print*,wlnv +c print*,"" +c print*,wlni +c stop + +300 CONTINUE ! fin notfirstcall + + +c ----------------------------- +c on ne recalcule pas optci si microfi=0 et compo lellouch +c ----------------------------- + IF ((MICROFI.ge.1).or.(.not.ylellouch)) THEN + IF(notfirstcall) THEN !F au 1er appel T aux autres appels!! + print*,'aerosol/gas/cloud properties' + CALL OPTCI(ycomp,qaer,nmicro,IPRINT) ! #1 + ENDIF + ENDIF + +c ni optcv si microfi=0 + + IF (MICROFI.ge.1) THEN + IF(notfirstcall) THEN !F au 1er appel T aux autres appels!! + print*,'aerosol/gas/cloud properties' + CALL OPTCV(qaer,nmicro,IPRINT) ! #2 + ENDIF + ENDIF + +c ----------------------------- + if (klon.eq.1) then + ig=1 + else + ig=klon/2 + endif +c print*,"DTAUI(equateur,:,1)=",DTAUI(ig,:,1) +c print*,"DTAUI(equateur,:,10)=",DTAUI(ig,:,10) +c print*,"DTAUI(equateur,:,NSPECI)=",DTAUI(ig,:,NSPECI) +c print*,"DTAUV(equateur,:,1,2)=",DTAUV(ig,:,1,2) +c print*,"DTAUV(equateur,:,10,2)=",DTAUV(ig,:,10,2) +c print*,"DTAUV(equateur,:,NSPECV,2)=",DTAUV(ig,:,NSPECV,2) +c stop + + notfirstcall=.true. + + RETURN + 191 FORMAT(F8.2,1P10E10.2) + 192 FORMAT(a8,1P10E10.2) + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/rdf.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/rdf.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/rdf.F (revision 1643) @@ -0,0 +1,82 @@ + subroutine rdf() + + + +#include "dimensions.h" +#include "microtab.h" +#include "clesphys.h" + + common/part/v,rayon,vrat,dr,dv + +* declaration des variables communes +* ---------------------------------- + + integer xnz,xnrad,xnztop + integer li,lf,h +* nrad dans microtab.h + real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) + +* controles + + + +* definition de la grille de rayon +* -------------------------------- + print*,'NOUVELLE GRILLE RAYON BASEE SUR 40 BINS' + print*,'ATTENTION; TRAVAIL AVEC UN NOUVEAU RAYON' + print*,' DE MONOMER : ' + cbase=nint(40./nrad)*1. + pi=3.1415926 + rayon(1)=13e-10*2**((cbase/2.-.5)/3.) + rayon(1)=13e-10*2.**.3333333333333 !<***** + vrat=2.**cbase + v(1)=4./3.*pi*rayon(1)**3 + + do 9 i=1,nrad-1 + rayon(i+1)=rayon(1)*vrat**(i/3.) + v(i+1)=v(1)*vrat**i +9 continue + + do 10 i=1,nrad + dv(i)=((vrat-1.)/(vrat+1.))*2.*v(i) + dr(i)=(2./(vrat+1))**(1./3.)*(vrat**(1./3.)-1.)*rayon(i) +10 continue + + + + + +* parametres fractals : rf & df(h) +*------------------------------------ + + rf0=0.066e-6 !Rayon monomere...OBLIGATOIRE meme en df=3! + !meme si dans ce cas, sa valeur n'a aucune + !importance + do h=1,nrad + rf(h)=rf0 !<********* + enddo + + print*, rf(5),' METRES ' + + do h=1,nrad + df(h)=3. !Df pour petites particules + if(rayon(h).ge.rf(h)) df(h)=df_GP + enddo + + + + aknc=2.92 !<--------Df=3 + aknc=6.86 !<--------Df=2 + + + print*,'tcorrect=',tcorrect,' tx=',tx + print*,'Df aerosols /1 a nqtot/' + write(*,*) (rf(h),h=1,nrad) + write(*,*) (df(h),h=1,nrad) + write(*,*) (rayon(h),h=1,nrad) + + + + return + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/refliq.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/refliq.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/refliq.F (revision 1643) @@ -0,0 +1,26 @@ + FUNCTION REFLIQ(W) + DIMENSION WAVENO(55),XIMG(55) + DATA WAVENO/0., 10., 40., 60., 80., 100., 120., 140., + &160., 180., 200., 220., 240., 260., 280., 300., 325., + &340., 350., 360., 380., 400., 450., 480., 500., 520., + &540., 560., 600., 640., 684., 720., 760., 780., 800., + &840., 875., 920., 960., 1000., 1040., 1080., 1120., 1160., + &1200., 1220., 1240., 1260., 1280., 1300., 1320., 1340., + &1400., 1800., 2000./ + DATA XIMG/1.0E-5, 5.0E-5, 1.1E-3, 1.5E-3, 1.9E-3, 2.3E-3, + &2.4E-3, 2.5E-3, 2.4E-3, 2.2E-3, 1.8E-3, 1.3E-3, 1.1E-3, + &8.6E-4, 6.8E-4, 5.0E-4, 4.0E-4, 2.9E-4, 2.0E-4, 1.8E-4, + &1.2E-4, 5.0E-5, 2.0E-5, 2.1E-5, 2.3E-5, 2.7E-5, 3.1E-5, + &3.5E-5, 5.0E-5, 6.2E-5, 9.0E-5, 1.2E-4, 1.7E-4, 2.0E-4, + &2.4E-4, 3.3E-4, 4.5E-4, 6.2E-4, 9.0E-4, 1.3E-3, 2.0E-3, + &2.9E-3, 4.4E-3, 6.6E-3, 1.0E-2, 1.3E-2, 1.9E-2, 3.0E-2, + &7.0E-2, 1.6E-1, 7.0E-2, 6.0E-3, 6.0E-3, 6.0E-3, 6.0E-3/ + DO 100 I=2,55 + IF (W .GT. WAVENO(I)) GO TO 100 + FACTOR= (WAVENO(I) - W )/(WAVENO(I) - WAVENO(I-1)) + REFLIQ=XIMG(I) + FACTOR*(XIMG(I-1) - XIMG(I)) + RETURN + 100 CONTINUE + REFLIQ=XIMG(55) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/regis.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/regis.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/regis.F (revision 1643) @@ -0,0 +1,72 @@ + SUBROUTINE REGIS (FNU,ND1,NNU,T,ND2,NT,XN2N2,XCH4CH4,XN2CH4,XN2H2) +C THIS SUBROUTINE RETURNS THE PRESSURE INDUCED ABSORBTION COEFFICIENTS +C FOR N2-N2, CH4-CH4, N2-CH4 + CH4-N2, H2-N2 + N2-H2. +C FNU IS THE WAVENUMBER ARRAY +C T IS THE TEMPERATURE ARRAY +C NNU IS THE NUMBER OF WAVENUMBERS +C NT IS THE NUMBER OF TEMPERATURES +C ND1 IS THE DIMENSION OF THE WAVENUMERS +C ND2 IS THE DIMENSION OF THE TEMPERATURES +C XN2N2(ND1,ND2) IS THE N2-N2 COEFFICIENT +C XCH4CH4(ND1,ND2) IS THE CH4-CH4 COEFFICIENT +C XN2CH4(ND1,ND2) IS THE N2-CH4 + CH4-N2 COEFFICIENT +C XN2H2(ND1,ND2) IS THE N2-H2 + H2-N2 COEFFICIENT +C FROM REGIS COURTIN ADAPTED BY CPM. + IMPLICIT REAL (A-H,O-Z) + DIMENSION FNU(NNU),T(NT), + & XN2N2(ND1,ND2),XCH4CH4(ND1,ND2),XN2H2(ND1,ND2),XN2CH4(ND1,ND2) + DIMENSION F8MN(100),F8NH(100),F8HN(100),F10(100), + 2 XN2R(100),XN2T(100),XCH4R(100),XCH4T(100),XH2R(100),XH2T(100) + DATA EPS1/71.4/,EPS2/148.6/,EPS3/36.8/ + DO 1 IT=1,NT + EPS4=SQRT(EPS1*EPS2) + EPS5=SQRT(EPS1*EPS3) + Y=4.*EPS4/T(IT) + F8MN(IT)=FI8(Y) + F10(IT)=FI10(Y) + Y=4.*EPS5/T(IT) + Z=FI8(Y) + F8NH(IT)=Z + F8HN(IT)=Z + Y=4.*EPS1/T(IT) + Z=FI8(Y) + F8MN(IT)=F8MN(IT)/Z + F8HN(IT)=F8HN(IT)/Z + Y=4.*EPS2/T(IT) + F10(IT)=F10(IT)/FI10(Y) + Y=4.*EPS3/T(IT) + F8NH(IT)=F8NH(IT)/FI8(Y) +1 CONTINUE + CALL PIAN2(0.,NT,XN2R,XN2T,T) + CALL PIACH4(0.,NT,XCH4R,XCH4T,T) + CALL PIAH2(0.,NT,XH2R,XH2T,T) + DO 2 INU=1,NNU + CALL OPAN2(FNU(INU),NT,XN2R,XN2T,T) + CALL OPACH4(FNU(INU),NT,XCH4R,XCH4T,T) + CALL OPAH2(FNU(INU),NT,XH2R,XH2T,T) +c!!!! CALL OPAN2(FNU(INU),NT,XN2R,XN2T) +c!!!! CALL OPACH4(FNU(INU),NT,XCH4R,XCH4T) +c!!!! CALL OPAH2(FNU(INU),NT,XH2R,XH2T) + DO 11 IT=1,NT + XN2N2(INU,IT)=XN2R(IT)+XN2T(IT) + XCH4CH4(INU,IT)=XCH4R(IT)+XCH4T(IT) +C +C LINES 1 AND 3 ARE CORRECTION FACTORS INTRODUCED IN ORDER TO FIT +C THE MEASUREMENTS OF DAGG ET AL (1986) BETWEEN 126 AND 212 K. +C + XN2CH4(INU,IT)=F8MN(IT)*(2.067*XN2R(IT)+2.865*XN2T(IT)) + 1 * 2.48/(T(IT)**0.184) + + 2 F10(IT)*(0.480*XCH4R(IT)+0.374*XCH4T(IT)) + 3 * 1.54 +C +C LINE 3 IS A CORRECTION FACTOR INTRODUCED IN ORDER TO FIT +C THE MEASUREMENTS OF DORE ET AL (1986) BETWEEN 91 AND 298 K. +C OTHER CORRECTION FACTORS ARE IMBEDDED IN THE ROUTINE PIAH2. +C + XN2H2(INU,IT)= F8NH(IT)*(2.543*XH2R(IT)+1.445E1*XH2T(IT)) + + 2 F8HN(IT)*(0.360*XN2R(IT)+0.246*XN2T(IT)) + 3 * 0.30 +11 CONTINUE +2 CONTINUE + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/setpia.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/setpia.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/setpia.F (revision 1643) @@ -0,0 +1,57 @@ + SUBROUTINE SETPIA(IPRINT,IFLAG) + PARAMETER (NSPECI=46,NSPC1I=47, NTEMPS=14) + REAL PIANN,PIACC,PIACN,PIAHN,T,W + COMMON /PIAC/ PIANN(NSPECI,NTEMPS),PIACC(NSPECI,NTEMPS) + & ,PIACN(NSPECI,NTEMPS),PIAHN(NSPECI,NTEMPS),TMIN,TMAX + COMMON /SPECTI/ BWNI(NSPC1I),WNOI(NSPECI),DWNI(NSPECI) + & ,WLNI(NSPECI) + DIMENSION T(NTEMPS),W(NSPECI) + DATA TMAX,TMIN/190.,60./ + DO 11 K=1,NSPECI + DO 11 NT=1,NTEMPS + PIANN(K,NT)=0.0 + PIACC(K,NT)=0.0 + PIACN(K,NT)=0.0 + PIAHN(K,NT)=0.0 + 11 CONTINUE + NWAVES=NSPECI + DO 99 INU=1,NSPECI + W(INU)=WNOI(INU) + IF (WNOI(INU) .LT. 1000.) GOTO 99 + NWAVES=INU-1 + GO TO 991 + 99 CONTINUE + 991 CONTINUE + DT=(TMAX-TMIN)/(NTEMPS-1) + DO 12 I=1,NTEMPS + T(I)=TMIN + (I-1)*DT + 12 CONTINUE + CALL REGIS (W,NSPECI,NWAVES,T,NTEMPS,NTEMPS, + & PIANN,PIACC,PIACN,PIAHN) + RETURN +CC TO BE DELETED... + 1234 NT=NTEMPS + NNU=NSPECI + WRITE(6,101) +101 FORMAT(/55X,'N2-N2 ABSORPTION'//) + WRITE(6,100) (T(IT),IT=1,NT) +100 FORMAT(2X,'NU\T',13F9.0/) + DO 3 INU=1,NNU +3 WRITE(6,110) WNOI(INU),(PIANN(INU,IT),IT=1,NT) + WRITE(6,103) +103 FORMAT(/55X,'CH4-CH4 ABSORPTION'//) + WRITE(6,100) (T(IT),IT=1,NT) + DO 5 INU=1,NNU +5 WRITE(6,110) WNOI(INU),(PIACC(INU,IT),IT=1,NT) + WRITE(6,105) +105 FORMAT(/50X,'N2-CH4 + CH4-N2 ABSORPTION'//) + DO 7 INU=1,NNU +7 WRITE(6,110) WNOI(INU),(PIACN(INU,IT),IT=1,NT) + WRITE(6,102) +102 FORMAT(/55X,'N2-H2 + H2-N2 ABSORPTION'//) + WRITE(6,100) (T(IT),IT=1,NT) + DO 4 INU=1,NNU +4 WRITE(6,110) WNOI(INU),(PIAHN(INU,IT),IT=1,NT) +110 FORMAT(1X,F5.0,2X,13(1PD9.2)) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/setspi.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/setspi.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/setspi.F (revision 1643) @@ -0,0 +1,57 @@ + SUBROUTINE SETSPI(IPRINT) + PARAMETER (NSPECI=46,NSPC1I=47) + COMMON /SPECTI/ BWNI(NSPC1I),WNOI(NSPECI),DWNI(NSPECI) + & ,WLNI(NSPECI) +C SET UP SPECRAL INTERVALS + BWNI(1)=8. + BWNI(2)=15. + BWNI(3)=25. + BWNI(4)=37.5 + DO 100 K=5,27 + BWNI(K)=BWNI(K-1)+25. + 100 CONTINUE + BWNI(28)=645. + BWNI(29)=645.+35.6760 + BWNI(30)=BWNI(29)+4.324/2. + BWNI(31)=BWNI(30)+4.324/2. + BWNI(32)=BWNI(31)+12.327/4. + BWNI(33)=BWNI(32)+12.327/4. + BWNI(34)=BWNI(33)+12.327/4. + BWNI(35)=BWNI(34)+12.327/4. + BWNI(36)=BWNI(35)+35.6290 + BWNI(37)=BWNI(36)+7.044/4. + BWNI(38)=BWNI(37)+7.044/4. + BWNI(39)=BWNI(38)+7.044/4. + BWNI(40)=BWNI(39)+7.044/4. + BWNI(41)=BWNI(40)+16.32/3. + BWNI(42)=BWNI(41)+16.32/3. + BWNI(43)=BWNI(42)+16.32/3. + BWNI(44)=BWNI(43)+156.48 + BWNI(45)=BWNI(44)+27.2/3. + BWNI(46)=BWNI(45)+27.2/3. + BWNI(47)=BWNI(46)+27.2/3. +C +C SET UP MEAN WAVENUMBERS AND DELTAS +C UNITS ON WAVENUMBER ARE CM-1 +C UNITS ON WAVELN ARE MICRONS + DO 160 K=1,NSPECI + WNOI(K)=( BWNI(K+1)+BWNI(K) )*0.5 + DWNI(K)=BWNI(K+1)-BWNI(K) + WLNI(K)=1.E+4/WNOI(K) + 160 CONTINUE +C IF THERE IS ONLY ONE INTERVAL THEN TOTAL ENERGY IS USED AND + IF (NSPECI .EQ. 1) DWNI(1) = 1.0 +C PRINT OUT SPECTRAL INTERVALS + IF (IPRINT .GT. 1) THEN + WRITE (6,190) + DO 200 K=1,NSPECI + WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K) + & ,BWNI(K+1),DWNI(K) + 200 CONTINUE + END IF + 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) + 190 FORMAT(///' SPECTRAL INTERVALS'// + & ' SNUM MICRONS WAVENU INTERVAL',11X,'DELTA-WN') +C ***** END SPECTRAL INTERVAL SET UP ************* + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/setspv.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/setspv.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/setspv.F (revision 1643) @@ -0,0 +1,119 @@ + SUBROUTINE SETSPV(IPRINT) + INTEGER NSPECV,NSPC1V + PARAMETER (NSPECV=24,NSPC1V=25) + REAL BWNV(NSPC1V),WNOV(NSPECV),DWNV(NSPECV) + REAL WLNV(NSPECV) + INTEGER NTERM(NSPECV) + REAL SOLARF(NSPECV),PEXPON(NSPECV) + REAL ATERM(4,NSPECV),BTERM(4,NSPECV) + + COMMON /SPECTV/ BWNV,WNOV,DWNV,WLNV + COMMON /VISGAS/SOLARF,NTERM,PEXPON,ATERM,BTERM + + DATA WLNV/ + & 0.325, 0.375, 0.425, 0.475, 0.525, 0.575, + & 0.640, 0.715, 0.789, 0.850, 0.891, 0.935, + & 0.998, 1.073, 1.144, 1.213, 1.292, 1.381, + & 1.484, 1.603, 1.742, 1.909, 2.111, 2.361/ + data solarf/ + & 525.430, 680.440, 1051.900, 1173.300, 1082.000, 1056.500, + & 1495.100, 1123.100, 1053.200, 541.820, 397.630, 484.210, + & 624.540, 528.390, 383.250, 372.260, 360.090, 339.230, + & 315.600, 292.580, 267.600, 239.700, 208.040, 180.550/ + data NTERM/1,1,4,4,4,3,4,4,3,4,3,3,3,4,4,3,3,4,3,4,4,3,4,4/ + data pexpon/ + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.149, 0.156, 0.186, + & 0.302, 0.097, 1.150, 1.040, 1.030, 1.040, + & 1.080, 1.070, 1.090, 1.050, 1.050, 0.959/ + data ATERM/ + & 1.000000, 0.000000, 0.000000, 0.000000, 1.000000, 0.000000, + & 0.000000, 0.000000, 0.700000, 0.093900, 0.015000, 0.191100, + & 0.300030, 0.135014, 0.460546, 0.104410, 0.164416, 0.375038, + & 0.295630, 0.164917, 0.444755, 0.355864, 0.199380, 0.000000, + & 0.198120, 0.331633, 0.335834, 0.134413, 0.327300, 0.335500, + & 0.146800, 0.190400, 0.277055, 0.333367, 0.389578, 0.000000, + & 0.126666, 0.416016, 0.364590, 0.092728, 0.286216, 0.492476, + & 0.221308, 0.000000, 0.445402, 0.453717, 0.100882, 0.000000, + & 0.351017, 0.371854, 0.277129, 0.000000, 0.434400, 0.477200, + & 0.077600, 0.010800, 0.292343, 0.374023, 0.242032, 0.091602, + & 0.501604, 0.385625, 0.112771, 0.000000, 0.597075, 0.308155, + & 0.094771, 0.000000, 0.116916, 0.447207, 0.338013, 0.097864, + & 0.541475, 0.367862, 0.090663, 0.000000, 0.468164, 0.212875, + & 0.213276, 0.105685, 0.245440, 0.416617, 0.242734, 0.095209, + & 0.330423, 0.503512, 0.166065, 0.000000, 0.307538, 0.361097, + & 0.232456, 0.098909, 0.115609, 0.353355, 0.413319, 0.117718/ + data BTERM/ + &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00, + &0.0000E+00,0.0000E+00,0.0000E+00,7.8260E-04,2.3210E-03,5.5120E-03, + &0.0000E+00,9.4390E-04,4.5750E-03,4.2690E-02,1.9500E-04,2.5340E-03, + &1.5020E-02,8.9550E-02,2.5430E-03,1.5420E-02,3.1900E-02,0.0000E+00, + &7.1740E-03,2.6010E-02,9.7160E-02,4.4030E-01,4.4550E-02,1.8750E-01, + &7.9000E-01,2.8660E+00,5.6920E-02,1.9440E-01,7.9630E-01,0.0000E+00, + &3.1190E-02,4.9600E-01,2.2970E+00,2.8660E+01,1.2740E+00,1.4250E+01, + &1.4070E+02,0.0000E+00,9.4170E-02,6.1850E-01,6.9190E+00,0.0000E+00, + &1.8690E+00,1.2560E+01,1.4730E+02,0.0000E+00,1.3600E-01,9.3830E-01, + &4.2070E+00,1.4080E+02,6.1300E-02,1.3220E+00,2.2710E+01,8.5640E+02, + &0.0000E+00,6.0630E-01,3.9880E+01,0.0000E+00,0.0000E+00,6.0850E-01, + &4.5140E+01,0.0000E+00,2.7190E-01,1.9420E+00,3.1990E+01,1.5370E+03, + &0.0000E+00,5.8440E-01,5.0650E+01,0.0000E+00,6.2920E-03,7.8350E-01, + &3.5630E+01,1.2870E+03,1.7680E+00,3.0850E+01,4.6500E+02,1.3940E+04, + &0.0000E+00,6.6970E-01,4.6030E+01,0.0000E+00,0.0000E+00,7.3460E-01, + &3.9680E+01,3.1920E+03,9.5930E+00,3.7750E+02,5.1130E+03,2.7940E+05/ +C ****** +C SET UP SPECRAL INTERVALS THESE ARE BASED ON KATHY RAGES PROGRAM +C CONVERT PER KM-AMAGATS TO PER GM CM-3 (SEE NOTES FOR CONSTANT) +C&& + FUV=2.5 +c fuv=1. +C&& + SOLARF(1) = FUV*SOLARF(1) +C&& + SOLARF(2) = FUV*SOLARF(2) +C + DO 101 K=1,NSPECV + DO 102 NT=1,4 + BTERM(NT,K)=BTERM(NT,K)/(1.E5 * 16./22.4E3) +102 CONTINUE +101 CONTINUE +C +C SET UP MEAN WAVENUMBERS AND DELTAS +C UNITS ON WAVENUMBER ARE CM-1 +C UNITS ON WAVELN ARE MICRONS + BWNV(1)=1.E4/.3 + DO 100 K=2,NSPC1V + BWLN=1.E4/BWNV(K-1) + EWLN=2.*WLNV(K-1)-BWLN + BWNV(K)=1.E4/EWLN + 100 CONTINUE + DO 160 K=1,NSPECV + WNOV(K)=1.E4/WLNV(K) + DWNV(K)=BWNV(K)-BWNV(K+1) + 160 CONTINUE +C IF THERE IS ONLY ONE SPECTRAL INTERVAL THEN TOTAL E IS USED AND + IF (NSPECV .EQ. 1) DWNV(1) =1.0 +C PRINT OUT SPECTRAL INTERVALS + IF (IPRINT .GT. 1) THEN + WRITE (6,190) + DO 200 K=1,NSPECV + WRITE (6,210)K,WLNV(K),WNOV(K),BWNV(K) + & ,BWNV(K)+DWNV(K),DWNV(K) + 200 CONTINUE + WRITE(6,320) + 320 FORMAT (///' J WAVELN SOLAR FLUX N NP [', + & 16X,'A TERMS',14X,'] [',16X,'B TERMS',14X,']'/) + DO 300 J=1,24 + K=1 + SUM=ATERM(K,J)+ATERM(K+1,J)+ATERM(K+2,J)+ATERM(K+3,J) + WRITE(6,20)J,WLNV(J),SOLARF(J),NTERM(J),PEXPON(J) + &,(ATERM(K,J),K=1,4),(BTERM(K,J),K=1,4) + 300 CONTINUE +c20 FORMAT(1X,I2,F7.4,1PE14.5,0PI2,F6.3,3X,1P8E10.3) + 20 FORMAT(1X,I2,F7.4,1PE14.5,I2,F6.3,3X,1P8E10.3) + END IF + 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) + 190 FORMAT(///' SPECTRAL INTERVALS'// + & ' SNUM MICRONS WAVENU INTERVAL',11X,'DELTA-WN') +C ****** END SPECTRAL INTERVAL SET UP ************* + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/sfluxv.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/sfluxv.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/sfluxv.F (revision 1643) @@ -0,0 +1,168 @@ + SUBROUTINE SFLUXV(IPRINT,IG,dist_sol,falbe,icld) + + use dimphy + USE TGMDAT_MOD, ONLY: UBARI,UBARV,UBAR0 + USE TGMDAT_MOD, ONLY: F0PI + IMPLICIT NONE +#include "dimensions.h" +#include "comorbit.h" + +c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX + INTEGER ngrid + PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon +c + INTEGER IG,IPRINT,icld + real dist_sol,falbe(ngrid) + + INTEGER NLAYER,NLEVEL,NSPECV,NSPC1V + PARAMETER (NLAYER=llm,NLEVEL=NLAYER+1) + PARAMETER (NSPECV=24,NSPC1V=25) + INTEGER NT,NTERM(NSPECV),J,K + + REAL FUW(NLEVEL),FDW(NLEVEL) + REAL DT0(NLAYER),T0(NLEVEL),WB0(NLAYER),CO0(NLAYER) + REAL BTOP, BSURF + REAL ATERM(4,NSPECV),BTERM(4,NSPECV) + REAL PEXPON(NSPECV), SOLARF(NSPECV) + REAL DTAUV(ngrid,NLAYER,NSPECV,4) + & ,TAUV (ngrid,NLEVEL,NSPECV,4) + & ,WBARV(ngrid,NLAYER,NSPECV,4) + & ,COSBV(ngrid,NLAYER,NSPECV,4) + & ,DTAUVP(ngrid,NLAYER,NSPECV,4) + & ,TAUVP(ngrid,NLEVEL,NSPECV,4) + & ,WBARVP(ngrid,NLAYER,NSPECV,4) + & ,COSBVP(ngrid,NLAYER,NSPECV,4) + REAL BWNV(NSPC1V),WNOV(NSPECV) + & ,DWNV(NSPECV),WLNV(NSPECV) + REAL FNETV(ngrid,NLEVEL), + & FUPV(ngrid,NLEVEL,NSPECV), + & FDV(ngrid,NLEVEL,NSPECV), + & FMNETV(ngrid,NLEVEL), + & FMUPV(NLEVEL),FMDV(NLEVEL) + + COMMON /VISGAS/SOLARF,NTERM,PEXPON, + & ATERM,BTERM + + COMMON /OPTICV/ DTAUV + & ,TAUV + & ,WBARV + & ,COSBV + & ,DTAUVP + & ,TAUVP + & ,WBARVP + & ,COSBVP + + COMMON /SPECTV/ BWNV,WNOV + & ,DWNV,WLNV + + COMMON /FLUXvV/ FNETV, + & FUPV, + & FDV, + & FMNETV + + +* ON NE FAIT PAS LE CALCUL POUR TOUS LES IG EN MEME TEMPS +* IG EST EN ARGUMENT...et SFLUXV EST APPELLEE NGRIDMX FOIS! + +C ZERO THE NET FLUXES + DO 212 J=1,NLEVEL + FNETV(ig,J)=-0. + FMNETV(ig,J)=-0. + 212 CONTINUE +C +C WE NOW ENTER A MAJOR LOOP OVER SPECRAL INTERVALS IN THE VISIBLE +C AND OVER THE HORIZONTAL GRIDS +C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL +C +C *************************************************************** + + + DO 500 K=1,NSPECV ! #2 +C ZERO THE SPECTRAL FLUXES IN ANTCIPATION OF SUMMING OVER NTERMS + + DO 214 J=1,NLEVEL ! #3 + FUPV(ig,J,K)=0. + FDV(ig,J,K)=0. + 214 CONTINUE +C +C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE + F0PI=SOLARF(K)*(p_elips/dist_sol)**2. + BTOP=0.0 +C +C LOOP OVER THE NTERMS BEGINING HERE + DO 912 NT=1,NTERM(K) + IF (ICLD.eq.1) THEN + BSURF=0.+ falbe(ig)*UBAR0*F0PI*EXP(-TAUV(ig,NLEVEL,K,NT)/UBAR0) + ELSE + BSURF=0.+ falbe(ig)*UBAR0*F0PI*EXP(-TAUVP(ig,NLEVEL,K,NT)/UBAR0) + ENDIF +C +C* WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM +C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS +C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER +C +C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO +C RETURN FLUXES FOR A GIVEN NT +C +C23456789012345678901234567890123456789012345678901234567890123456789012 +C +C USE DT0,T0,WB0,CO0 INSTEAD OF DTAUV(ig,1,K,NT)..etc... + + IF (ICLD.EQ.1) THEN + DO J=1,NLAYER + DT0(J)=DTAUV(ig,J,K,NT) + T0(J) =TAUV(ig,J,K,NT) + WB0(J)=WBARV(ig,J,K,NT) + CO0(J)=COSBV(ig,J,K,NT) + ENDDO + T0(NLEVEL)=TAUV(ig,NLEVEL,K,NT) + ELSE + DO J=1,NLAYER + DT0(J)=DTAUVP(ig,J,K,NT) + T0(J) =TAUVP(ig,J,K,NT) + WB0(J)=WBARVP(ig,J,K,NT) + CO0(J)=COSBVP(ig,J,K,NT) + ENDDO + T0(NLEVEL)=TAUVP(ig,NLEVEL,K,NT) + + ENDIF + +c PRINT*,'entree gfluxv #: ',ig,K +c write(*,*) (DT0(J),J=1,NLAYER) +c print*,'---' +c write(*,*) (T0(J),J=1,NLEVEL) +c print*,'---' +c write(*,*) (WB0(J),J=1,NLAYER) +c print*,'---' +c write(*,*) (CO0(J),J=1,NLAYER) +c print*,'UBAR0 ',UBAR0 +c print*,NLEVEL,WNOV(K),F0PI,falbe(ig),BTOP,BSURF + FUW = 0.0 + FDW = 0.0 + FMUPV=0.0 + FMDV= 0.0 + + CALL GFLUXV(NLEVEL,WNOV(K),DT0,T0, + & WB0,CO0,F0PI,falbe(ig),BTOP,BSURF,FUW,FDW,FMUPV, + & FMDV,IPRINT) +c PRINT*,'sortie gfluxv #: ',ig,K +c print*,'UBAR0 ',UBAR0 + +C NOW CALCULTE THE CUMULATIVE VISIBLE NET FLUX + + DO 300 J=1,NLEVEL !<------------ + FMNETV(ig,J)=FMNETV(ig,J)+( FMUPV(J)-FMDV(J) )*ATERM(NT,K) + FNETV(ig,J)=FNETV(ig,J)+( FUW(J)-FDW(J) )*ATERM(NT,K) + +C AND THE SPECTRAL FLUXES SUMMED OVER THE NTERMS + FUPV(ig,J,K)=FUPV(ig,J,K)+FUW(J)*ATERM(NT,K) + FDV(ig,J,K)=FDV(ig,J,K)+FDW(J)*ATERM(NT,K) + 300 CONTINUE !<-------------- +C +C + 912 CONTINUE + 500 CONTINUE + +C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE VISIBLE***** + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/snuages3D.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/snuages3D.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/snuages3D.F (revision 1643) @@ -0,0 +1,1683 @@ + subroutine snuages(ngrid,tab1,tab2,tab3,tab4,tab5, + & x1,xnz,xnrad,ihor,fluxi,taused,precip) + +!* +! +!1 c quantite de noyaux de la grille de rayon r a l'altitude z +!2 c quantite de glace 1 de la grille de rayon r a l'altitude z +!3 c quantite de glace 2 de la grille de rayon r a l'altitude z +!4 c quantite de glace 3 de la grille de rayon r a l'altitude z +!5 c quantite d'aerosols de la grille de rayon r a l'altitude z +c +c +!x1 timestep. + +c Notes : taused n'est actuellement pas calculé ! +c taused = dz/vitesse(z) +c +c +*--------------------------------------------------------------* +* * +* ENTRE 0 ET 1000 KILOMETRES * +* * +* la dimension fractale est en tableau, attention au * +* raccordement entre le regime moleculaire et le regime * +* fluide * +* * +* Modele microphysique: Cabane et al.,1992 / * +* Modele version fractale: Cabane et al.,1993 / * +* * +*--------------------------------------------------------------* +* VERSION DU 2 JUIN 1993 --- AUT 1994 --- 11/04/96 +* +* changer: altitude de production z0=/taux de production ctot= +* : la charge/micron, ne +* : df(h),rf... +* raccordement aknc +* +* declaration des blocs communs +*------------------------------ + + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2ctps/li,lf,dt + common/x2con/c,c1,c2,c3,caer + common/cldpart/rad,mmu + common/x2frac/rfg,dfg + common/x2effets/ xsaison + + +* declaration des variables communes +* ---------------------------------- + + integer xnz,xnrad,ngrid + integer i,j,k,ihor,ibidon + integer ihormx,imx + integer li,lf + real xsaison + real dt + real c(nz,nrad,2) + real c1(nz,nrad,2),c2(nz,nrad,2) + real c3(nz,nrad,2) + real caer(nz,nrad,2) + real rad(nz,nrad), mmu(nz,nrad) + real rtemp(nz,nrad),mmutemp(nz,nrad) + real knu,knu2,w + real rfg(nz),dfg(nz,nrad) + real ddt,dtau,vitesse2 + real vmax,vmin,rmax,rmin + real fluxi(ngrid,nz,3) + real taused(ngrid,nz) + real precip(ngrid,5) + real rmx + + +* variables internes +* ------------------ + + integer h,ti,itime,icoal + real tab1(nz,nrad),tab2(nz,nrad), + & tab3(nz,nrad),tab4(nz,nrad) + real tab5(nz,nrad) + real x1,xvolume,xmasse,xnoyaux + real knd1,knd2,knd3,knd4,knd5,knd6 + + real dice1,dice2,dice3,dice4 + + data itime/0/ + data icoal/0/ + save itime,icoal + save vmax,vmin,rmax,rmin + + +* controles +* --------- + + if (nrad.ne.xnrad) stop 'nrad.ne.xnrad' + if (nz.ne.xnz) stop 'nz.ne.xnz' + + do i=1,nz + do j=1,nrad + c(i,j,1)=tab1(i,j) + c(i,j,2)=0.0 + c1(i,j,1)=tab2(i,j) + c1(i,j,2)=0.0 + c2(i,j,1)=tab3(i,j) + c2(i,j,2)=0.0 + c3(i,j,1)=tab4(i,j) + c3(i,j,2)=0.0 + caer(i,j,1)=tab5(i,j) + caer(i,j,2)=0.0 + enddo + enddo + + +* initialisation +* -------------- + +* Parametres physiques de Titan + + if (itime.eq.0) then + call init2 + print*,'init2 dans snuages.F' + itime=1 + endif + + aknc=2.92 !<--------Df=3 + +* Propriete des gouttes nuageuses/ calculee ici pour la sedimentation +* r(i,j)=r (cst pour la colonne). Cela evite les accumulations dans +* certains niveaux du a des differences de vitesse de sedimentation... + +* ATTENTION, CES DEFINITIONS SONT INTERNES/ VOIR MUPHYS.F POUR DEFINITIONS +* EXTERNES (UTILISEES DANS OPTCV ET OPTCI, PAR EX.) + + do i=1,nz + xnoyaux=0. + xvolume=0. + xmasse=0. + do j=1,nrad + dfg(i,j)=3.00 + rfg(j)=6.6e-8 !<--- arbitraire pour df=3 + xnoyaux=xnoyaux+c(i,j,1) + xvolume=xvolume+c1(i,j,1)+c2(i,j,1)+c3(i,j,1)+ + & v_e(j)*c(i,j,1) + xmasse =xmasse+ + & c1(i,j,1)*rhoi_ch4+ + & c2(i,j,1)*rhoi_c2h6+ + & c3(i,j,1)*rhoi_c2h2+ + & v_e(j)*c(i,j,1)*rhol + enddo + + do j=1,nrad + + if (xnoyaux .le. 1.e-25 .or. xvolume.eq.0.) then ! utile ? + dfg(i,j)=3.00 + rtemp(i,j) = 1.e-9 + mmutemp(i,j)= rhol !on prend la masse vol des aerosols + else +c Mais pourquoi se compliquer la vie alors que de toute facon on +c reforce la masse volumique a son veritable calcul ^^ +c + if ((c1(i,j,1)+c2(i,j,1)+c3(i,j,1))/xvolume.le.0.1) then ! glace / total + dfg(i,j)=3.00 + rtemp(i,j) = ( (xvolume/xnoyaux)*0.75/pi)**(1./3.) +c mmutemp(i,j) = 1000. + mmutemp(i,j)= xmasse/xvolume + if(rtemp(i,j).gt.3.e-4) rtemp(i,j)=3.e-4 + else + dfg(i,j)=3.00 + rtemp(i,j) = ( (xvolume/xnoyaux)*0.75/pi)**(1./3.) + mmutemp(i,j)= xmasse/xvolume + if(rtemp(i,j).gt.3.e-4) rtemp(i,j)=3.e-4 + endif + endif + enddo + enddo + + do i=1,nz + do j=1,nrad + rad(i,j)=rtemp(i,1) ! mm valeur qqsoit j + mmu(i,j)=mmutemp(i,1) + enddo + enddo + + +* Coefficients de coagulation + + if (icoal.eq.1) call calcoag2 ! 2 <-- 1 + vmin=1.e+6 + vmax=0. + rmin=1.e+6 + rmax=0. + ihormx=1 + imx=1 + + +* choix interne du temps d iteration +* ---------------------------------- + + dt=x1 + +* iteration du modele sur le temps +* --------------------------------- + + li=1 + lf=2 + +* li=1 lf=2 + + call sedifn_fast(ihor,dice1,dice2,dice3,dice4) ! 1 <-- 1 +! call sedifn ! 2 <-- 1 + + li=3-li ! li devient 2 + lf=3-lf ! lf devient 1 + + if (icoal.eq.1) then +* li=2 lf=1 + call coagul2(ihor) ! 1 <-- 2 + + li=3-li ! li devient 1 + lf=3-lf ! lf devient 2 + + endif + + do i=1,nz + vmin=vitesse2(i,1,1) + do j=1,nrad + fluxi(ihor,nz+1-i,1)=fluxi(ihor,nz+1-i,1) + & -vmin*c1(i,j,li)*rhoi_ch4 + fluxi(ihor,nz+1-i,2)=fluxi(ihor,nz+1-i,2) + & -vmin*c2(i,j,li)*rhoi_c2h6 + fluxi(ihor,nz+1-i,3)=fluxi(ihor,nz+1-i,3) + & -vmin*c3(i,j,li)*rhoi_c2h2 + enddo + enddo + +c En theorie, les diceX sont NEGATIF (en sedimentant on ne fait que perdre de la glace) +c Les precipitations sont comptees positivement. (ET ON NE PREND QUE DES VALEURS POSITIVES !) + + precip(ihor,1)=AMAX1(-dice1/rhoi_ch4,0.) ! m3/m2 = m :) + precip(ihor,2)=AMAX1(-dice2/rhoi_c2h6,0.) + precip(ihor,3)=AMAX1(-dice3/rhoi_c2h2,0.) + precip(ihor,4)=AMAX1(-dice4/rhol,0.) + + do i=1,nz + do j=1,nrad + tab1(i,j)=c(i,j,li) ! li=1 + tab2(i,j)=c1(i,j,li) ! li=1 + tab3(i,j)=c2(i,j,li) ! li=1 + tab4(i,j)=c3(i,j,li) ! li=1 + enddo + enddo + + return + + end + + + +*______________________________________________________________________ + + real function lambda2(j,indic) +* +*------------------------------------------------------------------* +* fonction calculant le libre parcours moyen des molecules * +* atmospheriques( rayon =ra) se trouvant dans la couche no j. * +* pour indic=0 ...... la particule se trouve a la frontiere entre* +* les couches j et j-1 * +* pour indic=1 ...... la particule se trouve au milieu de la * +* la couche j * +*------------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2frac/rfg,dfg + +* declaration des variables communes +* ---------------------------------- + + real rfg(nz),dfg(nz,nrad) + +* declaration des variables internes +* ---------------------------------- + + integer indic,j + real pp,ra + + ra=1.75e-10 + +* traitement +* ---------- + + if (indic.eq.0) then + pp=pb(j) + else + if (indic.ne.1) then + print*,'erreur argument fonction lambda' + stop + endif + pp=p(j) + endif + + lambda2=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp) + end + +******************************************************************************* + + real function knu2(j,k,indic) +* +*--------------------------------------------------------------* +* fonction calculant le nombre de knudsen d'une particule * +* d'aerosol de rayon rad(k) se trouvant dans la couche no j * +* indic ...... idem function lambda * +*--------------------------------------------------------------* +* +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/cldpart/rad,mmu + common/x2frac/rfg,dfg + + +* declaration des variables communes +* ---------------------------------- + + real rad(nz,nrad),mmu(nz,nrad) + real rfg(nz),dfg(nz,nrad) + + +* declaration des variables internes +* ---------------------------------- + + integer indic,j,k + real lambda2,rfk + +* traitement +* ---------- + + if (indic.ne.0 .and.indic.ne.1) then + print*,'erreur argument fonction knu' + stop + endif + + + rfk=(rad(j,k)**(3./dfg(j,k)))*((rfg(k))**(1.-3./dfg(j,k))) + knu2=lambda2(j,indic)/rfk + + end + +***************************************************************************** + + real function nud2(j,indic) +* +*--------------------------------------------------------------* +* fonction calculant la viscosite dynamique (en USI) de l air * +* d apres la formule de Sutherlant a l altitude j * +* indic ......... idem fonction lambda * +*--------------------------------------------------------------* +* + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + integer indic,j + real nud0,c,tt + real rfg(nz),dfg(nz,nrad) + + common/x2frac/rfg,dfg + +* + nud0=1.74e-5 + c=109. + + if(indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction nud' + stop + endif + + if (indic.eq.0) tt=tb(j) + if (indic.eq.1) tt=t(j) + nud2=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt) + end + +**************************************************************************** + + real function vitesse2(j,k,indic) +* +*-----------------------------------------------------------------* +* fonction calculant la vitesse de chute d une particule de rayon* +* k se trouvant a l altitude j suivant la valeur du nombre de * +* Knudsen * +* indic ....... idem function lambda * +*-----------------------------------------------------------------* +* + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + common/cldpart/rad,mmu + common/x2frac/rfg,dfg + common/x2ctps/li,lf,dt + +* declaration des variables communes +* ---------------------------------- + + real rad(nz,nrad),mmu(nz,nrad) + real rfg(nz),dfg(nz,nrad) + + +* declaration des variables internes +* ---------------------------------- + + integer indic,j,k,li,lf + real w,g,m,a0,zz,knu2,nud2,knud,tt,rhoh + real vlimite,akncx,rbis,rfk + real dt + +* traitement +* ---------- + + if (indic.ne.0.and.indic.ne.1) then + print*,'erreur argument fonction vitesse' + stop + endif + + if(indic.eq.0) then + zz=z(j)+dz(j)/2. + tt=tb(j) + rhoh=rhob(j) + endif + if(indic.eq.1) then + zz=z(j) + tt=t(j) + rhoh=rho(j) + endif + + g=g0*(rtit/(rtit+zz))**2 + a0=0.74 + m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav + knud=knu2(j,k,indic) + +c akncx=aknc +c if(df(k).gt.2.5) akncx=2.7 + +c if(knud.ge.akncx) then +c rbis=(rad(j,k)**(3.-6./dfg(j,k)))*((rfg(k))**(-2.+6./dfg(j,k))) +c w=a0*g*rbis*mmu(j,k)/(rhoh*sqrt(8*kbz*tt/(pi*m))) +c endif + + rfk=(rad(j,k)**(3./dfg(j,k)))*((rfg(k))**(1.-3./dfg(j,k))) + w=2./9.*rfk**(dfg(j,k)-1.)*rfg(k)**(3.-dfg(j,k))*g*mmu(j,k) + & /nud2(j,indic) + + w=w*(1+1.2517*knud+0.4*knud*exp(-1.1/knud)) + + w=w!*3. ! on tient compte de la largeur de distribution... a affiner + vitesse2=w + + + end +*********************************************************************** + real function kd2(h) +* +*--------------------------------------------------------------------* +* cette fonction calcule le coefficient du terme de eddy diffusion * +* a l altitude j * +*--------------------------------------------------------------------* +* + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2frac/rfg,dfg + + real zbx + real rfg(nz),dfg(nz,nrad) + + integer h + + zbx=z(h)+dz(h)/2. + if(zbx.le.42000.) then +c kd2=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + kd2=4. + else + kd2=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.) + kd2=0.0*kd2 + endif + kd2=00. + + + return + end + + +*____________________________________________________________________________ + + subroutine init2 +* +*--------------------------------------------------------------------* +* cette routine effectue : * +* 1) interpolation a partir des donnees initiales des * +* valeurs de p,t,rho,ach4,aar,an2 sur la grille * +* 2) initialisation des constantes (common/x2phys/) * +* 3) initialisation des variables temporelles (common * +* /temps/) * +* 4) definition des grilles en rayon et verticale * +* 5) initialisation de c(z,r,t) avec les donnees du * +* fichier unit=1 * +* * +* les donnees sont des valeurs caracterisques de l atmosphere de * +* TITAN ( voir Lelouch and co ) * +*--------------------------------------------------------------------* + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + common/x2ctps/li,lf,dt + common/cldpart/rad,mmu + +* declaration des variables communes +* ---------------------------------- + + integer li,lf + real dt + real rad(nz,nrad), mmu(nz,nrad) + + +* declaration des variables internes +* ---------------------------------- + integer nzd,i,ii + parameter (nzd=254) + integer limsup,liminf,j1,j2 + real zd(nzd),ach4d(nzd),rap + real m + + +* initialisation des variables temporelles +* ---------------------------------------- + + li=1 + lf=2 + + +* interpolation de xch4,xar et xn2 sur la grille +* ---------------------------------------------- + +* donnees initiales (Lellouch et al,87) +* ------------------------------------- + +c print*,'****** init' + do 1 i=1,168 + zd(i)=(1000.-5*(i-1))*1000. +1 continue + do 2 i=1,78 + zd(168+i)=(160.-2*(i-1))*1000. +2 continue + do 3 i=1,4 + zd(246+i)=(5.-(i-1))*1000. +3 continue + do 4 i=1,4 + zd(250+i)=(1.5-(i-1)*0.5)*1000. +4 continue + + data (ach4d(i),i=1,168)/168*1.5e-2/ + data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2, + & 1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2, + & 4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/ + + liminf=0 + limsup=0 + +* interpolation des taux de melange de ch4,ar,n2 +*----------------------------------------------- + + do 20 j1=1,nz + do 21 j2=1,nzd + if( zd(j2).le.z(j1)) goto 22 +21 continue +22 liminf=j2 + if (zd(liminf).eq.z(j1) )then + ach4(j1)=ach4d(liminf) + goto 20 + endif + if (j2.ne.1) then + limsup=j2-1 + else + limsup=j2 + endif + if (limsup.eq.liminf) then + ach4(j1)=ach4(limsup) + else + ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/ + s (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1)) + endif +20 continue + +* rap= aar/an2 cst sur l altitude + + rap=0.191 + do 23 i=1,nz + an2(i)=(1.-ach4(i))/(1.+rap) + aar(i)=rap*an2(i) +23 continue + + do 24 i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rho(i)=p(i)*m/(rgp*t(i)) +24 continue + + do 34 i=1,nz + m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar + rhob(i)=pb(i)*m/(rgp*tb(i)) +c print*,pb(i),m,rgp,tb(i),rhob(i),rho(i) +34 continue + +* fin d interpolation des taux de melange +*---------------------------------------- + +c print*,'**** fin init' +540 continue + return + +500 print*,'erreur lecture initialisation de c...erreur=',ii + stop + + end + +*__________________________________________________________________________ + + subroutine sedifn +* +*------------------------------------------------------------------* +* cette routine calcule l evolution de la fonction de distribution* +* c(z,r,t) pour les phenomenes de sedimentation et de diffusion * +*------------------------------------------------------------------* +* +* +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2ctps/li,lf,dt + common/x2con/ctmp,c1,c2,c3,caer + common/cldpart/rad,mmu + common/x2frac/rfg,dfg + + +* declaration des variables communes +* ---------------------------------- + + integer li,lf + real dt + real c(nz,nrad,2) + real c1(nz,nrad,2) + real c2(nz,nrad,2) + real c3(nz,nrad,2) + real caer(nz,nrad,2) + real ctmp(nz,nrad,2) + real rad(nz,nrad),mmu(nz,nrad) + real rfg(nz),dfg(nz,nrad) + + +* declaration des variables internes +* ---------------------------------- + + real w,w1,dzbX,dc + integer i,j,k,ii,nb + double precision sigma,theta,hc,l,rap,cmp,wp + double precision fs(nz+1),ft(nz+1) + real as(nz),bs(nz),cs(nz),ds(nz) + double precision asi(nztop:nz),bsi(nztop:nz), + & csi(nztop:nz) + double precision dsi(nztop:nz),xsol(nztop:nz) + real vitesse2,kd2 + + external dtridgl + +* resolution +*------------ + + do 5 ii=1,4 + do k=1,nrad + do j=nztop,nz + if( ii.eq.1 ) c(j,k,li)=ctmp(j,k,li) + if( ii.eq.2 ) c(j,k,li)=c1(j,k,li) + if( ii.eq.3 ) c(j,k,li)=c2(j,k,li) + if( ii.eq.4 ) c(j,k,li)=c3(j,k,li) + enddo + enddo + + do 10 k=1,nrad + do 20 j=nztop,nz + if (j.eq.1) goto 20 +* calcul de la vitesse corrigee + + dzbX=(dz(j)+dz(j-1))/2. + w= -1*vitesse2(j,k,0) + + if (kd2(j).ne.0.) then + theta=0.5*(w*dzbX/kd2(j)+log(rho(j-1)/rho(j))) + if (theta.ne.0) then + sigma=1./dtanh(theta)-1./theta + else + sigma=1. + endif + else + sigma=1. + endif + + if(c(j,k,li).eq.0.) then + rap=10. + else + rap=c(j-1,k,li)/c(j,k,li) + if( rap.gt.10.) rap=10. + if( rap.lt.0.1) rap=0.1 + endif + + if (rap.gt.0.9 .and. rap.lt.1.1) then + w1=w + else + if(w.ne.0) then + hc=dzbX/dlog(rap) + l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap) + wp=w*1.d0 + cmp=dlog(-wp)+abs(sigma)*dlog(l) + if (cmp.gt.38) then + goto 20 + endif + w1=-dexp(cmp) + else + w1=0. + endif + endif + +* calcul des flux aux interfaces + + + if (kd2(j).ne.0.) then + if (theta.ne.0.) then + ft(j)=(w1+log(rho(j-1)/rho(j))*kd2(j)/dzbX)/ + & (dexp(2.*theta)-1.) + fs(j)=ft(j)*dexp(2.*theta) + else + ft(j)=kd2(j)/dzbX + fs(j)=kd2(j)/dzbX + endif + else + if (w1.lt.0.)then + ft(j)=-w1 + fs(j)=0. + else + ft(j)=0. + fs(j)=w1 + endif + endif + +20 continue + +* conditions aux limites pour les flux aux interfaces + + fs(1)=0. + ft(1)=0. + fs(nz+1)=0. + ft(nz+1)=-w1 + +* calcul des coefficients de l equation discrete + + do 21 j=nztop,nz + as(j)=-dz(j)/dt + bs(j)=-ft(j) + cs(j)=ft(j+1)+fs(j)-dz(j)/dt + ds(j)=-fs(j+1) + if ( cs(j).gt.0) goto 100 +21 continue + +* cas explicite (mu=0) : calcul de la fonction c(z,r,t+1) + + do 22 j=nztop,nz-1 + + if (j.eq.nztop) then + dc=(cs(nztop)*c(nztop,k,li)+ds(nztop) + & *c(nztop+1,k,li))/as(nztop) + c(nztop,k,lf)=dc + goto 22 + endif + + dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li)) + s /as(j) + c(j,k,lf)=dc + +22 continue + + dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz) + c(nz,k,lf)=dc + + if (nztop.ne.1) then + do 32 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +32 continue + endif + + goto 10 + +100 continue + +* cas implicite (mu=1) : calcul de la fonction c(z,r,t+1) + + do 101 j=nztop,nz + asi(j)=ft(j) + bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt) + csi(j)=fs(j+1) + dsi(j)=-dz(j)/dt*c(j,k,li) +101 continue + +* inversion de la matrice tridiagonale + + nb=nz-nztop+1 + + call dtridgl(nb,asi,bsi,csi,dsi,xsol) + + do 102 j=nztop,nz + c(j,k,lf)=xsol(j) +102 continue + + if (nztop.ne.1) then + do 110 j=1,nztop-1 + c(j,k,lf)=c(j,k,li) +110 continue + endif + + + +10 continue + + do k=1,nrad + do j=nztop,nz + if( ii.eq.1 ) ctmp(j,k,lf)=c(j,k,lf) + if( ii.eq.2 ) c1(j,k,lf) =c(j,k,lf) + if( ii.eq.3 ) c2(j,k,lf) =c(j,k,lf) + if( ii.eq.4 ) c3(j,k,lf) =c(j,k,lf) + enddo + enddo + +5 continue + + return + + end + +*__________________________________________________________________________ + + subroutine sedifn_fast(ihor,dice1,dice2,dice3,dice4) +* +*------------------------------------------------------------------ * +* cette routine calcule l evolution de la fonction de distribution * +* c(z,r,t) pour les phenomenes de sedimentation {pas de diffusion} * +* dice1 = delta glace CH4 * +* dice2 = delta glace C2H6 * +* dice3 = delta glace C2H2 * +* dice4 = delta Volume noyaux * +*------------------------------------------------------------------ * +* +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2ctps/li,lf,dt + common/x2con/c,c1,c2,c3,caer + common/cldpart/rad,mmu + common/x2frac/rfg,dfg + + +* declaration des variables communes +* ---------------------------------- + + integer li,lf,i,j,k,ihor + integer jinf,jsup,jj,iiter + real dt + real c(nz,nrad,2) + real c1(nz,nrad,2) + real c2(nz,nrad,2) + real c3(nz,nrad,2) + real caer(nz,nrad,2) + real ci(nz,nrad,2) + real ci1(nz,nrad,2) + real ci2(nz,nrad,2) + real ci3(nz,nrad,2) + real rad(nz,nrad),mmu(nz,nrad) + real rfg(nz),dfg(nz,nrad) + real puit(nz) +c ------ echange est cree sur la taille maxi mais n'est utilisee +c que sur la dim geree par le proc (klon ou jjm+1) + integer ngrid + parameter (ngrid=(jjm-1)*iim+2) ! = taille maximum + real echange(nz,nz,ngrid) +c pas genial mais vu que c est tres local, pas de soucis a priori en parallele. + real bilan1,bilan2,bilan3,bilan4,bilan5 + real bilan11,bilan12,bilan13,bilan14,bilan15 + real compte,compte2,xepl + real dice1,dice2,dice3,dice4 + + + +* declaration des variables internes +* ---------------------------------- + + real vitesse2,kd2 + real w,ws,wi,zs,zi,alpha,v0,deltazs,deltazi + real zni,znip1,xcnt,ichx,arg1,arg2,xft,xf + real argexp,explim + + save echange + + +* resolution +*------------ + + + bilan1=0. + bilan2=0. + bilan3=0. + bilan4=0. + bilan5=0. + do k=1,nrad + do j=nztop,nz + ci(j,k,li)= c(j,k,li)*dzb(j) ! li + ci1(j,k,li)=c1(j,k,li)*dzb(j) + ci2(j,k,li)=c2(j,k,li)*dzb(j) + ci3(j,k,li)=c3(j,k,li)*dzb(j) + bilan5=bilan5+ci(j,k,li) + bilan1=bilan1+ci1(j,k,li) + bilan2=bilan2+ci2(j,k,li) + bilan3=bilan3+ci3(j,k,li) + bilan4=bilan4+ + & ci(j,k,li)*4./3.*pi*rf(k)**3.*vrat_e**(k-imono) + + ci(j,k,lf)= 0. ! lf + ci1(j,k,lf)=0. + ci2(j,k,lf)=0. + ci3(j,k,lf)=0. + enddo + enddo + +* calcul de la matrice d echange +*---------------------------------------------------------------- + + do j=nztop,nz + do i=nztop,nz + echange(i,j,ihor)=0. + enddo + enddo + + do 20 i=nztop,nz + puit(i)=0. + do 30 k=1,1 + xcnt=0. + ICHX=1 ! extrapolation 0: lineaire 1: exponentielle + IF(ICHX.eq.0 .or. ICHX.eq.2) THEN + ws=vitesse2(i,k,0) + if(i.lt.nz) wi=vitesse2(i+1,k,0) + if(i.eq.nz) wi=vitesse2(i ,k,1) + w=(ws+wi)/2. + zni =zb(i)-w*dt + znip1=zb(i)-dzb(i)-w*dt + ENDIF + + explim=30. + + IF(ICHX.eq.1 .or. ICHX.eq.2) THEN + ws=vitesse2(i,k,0) + zs=zb(i) + wi=vitesse2(i,k,1) + zi=z(i) + +c if(wi.eq.ws) wi=ws/1.001 ! sinon ca plante ! + if(abs(wi-ws)/wi .le. 1.e-3) wi=ws/1.001 ! sinon ca plante ! + + if(wi.ne.0.) alpha= alog(ws/wi) /(zs-zi) + argexp=alpha*zs + if(argexp.lt.-explim) argexp=-explim + if(argexp.gt. explim) argexp=+explim + v0 = ws/exp(argexp) + + argexp=alpha*zb(i) + if(argexp.lt.-explim) argexp=-explim + if(argexp.gt. explim) argexp=+explim + arg1=1.+v0*alpha*exp(argexp)*dt + + argexp=alpha*(zb(i)-dzb(i)) + if(argexp.lt.-explim) argexp=-explim + if(argexp.gt. explim) argexp=+explim + arg2=1.+v0*alpha*exp(argexp)*dt + + iiter=0 +101 continue + + if (iiter.le.25) then + if(arg1.le.0. .or. arg2.le.0.) then + print*,ihor,i,iiter, 'ajustement vitesse',arg1,arg2 + print*,ws,wi, ' w1 w2 anc valeurs' + print*,alpha, ' alpha anc valeurs' + print*,rad(i,k), 'r(j,k)' + print*,mmu(i,k), ' mmu(j,k)' + print*,t(i), ' t(j,k)' + print*,arg1,arg2, ' arg1 arg2 anc valeurs' + arg2=1+(arg2-1.)/2. + arg1=1+(arg1-1.)/2. + iiter=iiter+1 + print*,arg1,arg2, ' arg1 arg2 nle valeurs' + goto 101 + endif + else + stop + endif + + if(arg1.lt.0.) print*,'arg1:',arg1 + if(arg2.lt.0.) print*,'arg2:',arg2 + + deltazs=-alog(arg1)/alpha + deltazi=-alog(arg2)/alpha + + zni =zb(i)+deltazs + znip1=zb(i)-dzb(i)+deltazi + + ENDIF + + if(zni.ne.znip1) xft=zni/(zni-znip1) + if(zni.eq.znip1 .and. zni.le.0.) xft=0. + if(zni.eq.znip1 .and. zni.gt.0.) then + xft=0. + print*,'zni..znip1', zni,znip1 + endif + +* Si des aerosols touchent le sol (zni < 0 ) alors on fixe +* le niveau a 0, et on elimine les aerosols correspondants +*----------------------------------------------------------- + + if(znip1 .lt. 0.) znip1=0. + if(zni .lt. 0.) zni =0. + + if(zni.le.0. .and. znip1 .le. 0.) then +c print*,'voie 1 / disparition complete' + xft=0. + xf=1. + xcnt=xcnt+xf + puit(i)=puit(i)+xf + endif + + if(zni.gt.0. .and. znip1 .le. 0.) then +c print*,'voie 2 / disparitipon partielle' + xf=(1-xft) + xcnt=xcnt+xf + puit(i)=puit(i)+xf + endif + + if(zni.gt.0. .and. znip1 .gt. 0.) then +c print*,'voie 3 / pas de disparition' + xft=1. + xf=(1-xft) + xcnt=xcnt+xf + puit(i)=puit(i)+xf + endif + + jsup=nz+1 + jinf=nz+1 + do j=nztop,nz + if(zni.le.zb(j) .and. zni.ge.zb(j)-dzb(j)) jsup=j + if(znip1.le.zb(j).and. znip1.ge.zb(j)-dzb(j)) jinf=j + enddo + if(zni .ge. 0. .and. zni .lt. 1.e-3) jsup=nz + if(znip1 .ge. 0. .and. znip1 .lt. 1.e-3) jinf=nz + + +* Volume inclu dans un seul niveau +*---------------------------------- + + if (jsup .eq. jinf. and. jsup.ge. nz+1) then + xcnt=xcnt+1. + print*,'cas impossible' + print*,'alpha= ',alpha + print*,'ws wi ',ws,wi + print*,'deltazs deltazi ',deltazs,deltazi + print*,' r(i,k) mmu(i,k)', rad(i,k),mmu(i,k) + print*,' t(j,k)',t(i) + print*,zni,znip1,jsup,jinf + print*,'STOP' + STOP + endif + + if (jsup .eq. jinf. and. jsup.le. nz) then + xf=1. + xcnt=xcnt+xft*xf + if(jinf.le.nz) then + echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf + endif + endif + +* Volume a cheval sur 2 niveaux +*-------------------------------- + + if (jinf .eq. jsup+1) then + xf=(zni-zb(jsup)+dzb(jsup))/(zni-znip1) + xcnt=xcnt+xf*xft + if(jsup.le.nz) then + echange(jsup,i,ihor)=echange(jsup,i,ihor)+xft*xf + endif + xf=(zb(jinf)-znip1)/(zni-znip1) + xcnt=xcnt+xf*xft + if(jinf.le.nz) then + echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf + endif + endif + +* Volume a cheval sur 3 ou plus de niveaux +*------------------------------------------ + + if (jinf .gt. jsup+1) then + +c print*,' voie C / dans N cases' + xf=(zni-zb(jsup)+dzb(jsup))/(zni-znip1) + xcnt=xcnt+xf*xft + if(jsup.le.nz) then + echange(jsup,i,ihor)=echange(jsup,i,ihor)+xft*xf + endif + + xf=(zb(jinf)-znip1)/(zni-znip1) + xcnt=xcnt+xf*xft + if(jinf.le.nz) then + echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf + endif + + do jj=jsup+1,jinf-1 + xf=(zb(jj)-zb(jj+1))/(zni-znip1) + xcnt=xcnt+xf*xft + if(jj.le.nz) then + echange(jj,i,ihor)=echange(jj,i,ihor)+xft*xf + endif + enddo + + endif + + +* et sur les rayons... +*--------------------- +30 continue + +* fin de la grande boucle sur les altitudes... +*---------------------------------------------- +20 continue + +* Calcul etat final Cfinal = Echange*initial +*---------------------------------------------- + + compte=0. + compte2=0. + do j=1,nz + xepl=0. + do jj=1,nz + xepl=xepl+echange(jj,j,ihor) + compte=compte+echange(jj,j,ihor) + compte2=compte2+echange(jj,j,ihor) + enddo + compte2=compte2+puit(j) + enddo + + if(abs(compte2-nz) .gt. 1.e-4) + & print*,'Matrice calculee#',ihor,'tx d expl (/55):', + & compte,compte2 + + +* Fin du calcul de la matrice d*echange +*---------------------------------------------- + + do j=nztop,nz + do k=1,nrad + + do jj=nztop,nz + ci(j,k,lf)=ci(j,k,lf)+ + & echange(j,jj,ihor)*ci(jj,k,li) + ci1(j,k,lf)=ci1(j,k,lf)+ + & echange(j,jj,ihor)*ci1(jj,k,li) + ci2(j,k,lf)=ci2(j,k,lf)+ + & echange(j,jj,ihor)*ci2(jj,k,li) + ci3(j,k,lf)=ci3(j,k,lf)+ + & echange(j,jj,ihor)*ci3(jj,k,li) + enddo + enddo + enddo + + +* Controles et affichage Bilan +*---------------------------------------------- + + bilan11=0. + bilan12=0. + bilan13=0. + bilan14=0. + bilan15=0. + do k=1,nrad + do j=nztop,nz + c(j,k,lf) =ci(j,k,lf)/dzb(j) + c1(j,k,lf)=ci1(j,k,lf)/dzb(j) + c2(j,k,lf)=ci2(j,k,lf)/dzb(j) + c3(j,k,lf)=ci3(j,k,lf)/dzb(j) + bilan15=bilan15+ ci(j,k,lf) + bilan11=bilan11+ci1(j,k,lf) + bilan12=bilan12+ci2(j,k,lf) + bilan13=bilan13+ci3(j,k,lf) + bilan14=bilan14+ + & ci(j,k,lf)*4./3.*pi*rf(k)**3.*vrat_e**(k-imono) + enddo + enddo + +c print*,'sedifn_fast Bilans:' +c & ,bilan11,bilan12,bilan13 +c print*,'Bilan1:',bilan1,bilan11 +c print*,'Bilan2:',bilan2,bilan12 +c print*,'Bilan3:',bilan3,bilan13 +c print*,'Bilan5:',bilan5,bilan15 + + dice1=0. + dice2=0. + dice3=0. + dice4=0. + dice1=(bilan11-bilan1)*rhoi_ch4 !glace 1 m^3.m^-2 * kg.m^-3 pourquoi ???? + dice2=(bilan12-bilan2)*rhoi_c2h6 !glace 2 + dice3=(bilan13-bilan3)*rhoi_c2h2 !glace 3 + dice4=(bilan14-bilan4)*rhol !noyaux + + return + end + + + subroutine coagul2(ihor) + +********************************************************* +* ce programme calcule la nouvelle concentration dans * +* le a ieme intervalle de rayon, a l'altitude h, a * +* l'instant t+dt * +********************************************************* + + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + +* declaration des blocs communs +*------------------------------ + + common/x2ctps/li,lf,dt + common/x2con/c,c1,c2,c3,caer + common/cldpart/rad,mmu + +* declaration des variables +* -------------------------- + + integer li,lf + real dt + real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2), + & c3(nz,nrad,2) + real caer(nz,nrad,2) + real rad(nz,nrad),mmu(nz,nrad) + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,a,ihor,i + real pr,pe,eta1,eta2 + real sum11,sum12,sum13,sum21,sum22,sum23 + real rfb,rfx,rpr + +* traitement +* ---------- + + + sum11=0. + sum12=0. + sum13=0. + sum21=0. + sum22=0. + sum23=0. + + do 10 h=nztop,nz + do 11 a=1,nrad ! boucle aerosol secs + call pertpro2(ihor,h,a,pe,pr) + + if(1+dt*pe .gt. 1.1) print*,a,1+dt*pe,' scav' + caer(h,a,lf)=(caer(h,a,li)+pr*dt)/(1+dt*pe) + c(h,a,lf)=c(h,a,li) + c1(h,a,lf)=c1(h,a,li) + c2(h,a,lf)=c2(h,a,li) +c +c eta1=0. +c eta2=0. +c if(c(h,a,li) .ne. 0.) eta1=c1(h,a,li)/c(h,a,li) +c if(c(h,a,li) .ne. 0.) eta2=c2(h,a,li)/c(h,a,li) +c c(h,a,lf) =( c(h,a,li)+pr*dt)/(1+dt*pe) +c c1(h,a,lf)=(c1(h,a,li)+eta1*pr*dt)/(1+dt*pe) +c c2(h,a,lf)=(c2(h,a,li)+eta2*pr*dt)/(1+dt*pe) +c +c +c sum11=sum11+c(h,a,li) +c sum12=sum12+c1(h,a,li) +c sum13=sum13+c2(h,a,li) +c +c sum21=sum21+ c(h,a,lf) +c sum22=sum22+c1(h,a,lf) +c sum23=sum23+c2(h,a,lf) +c +c +11 continue +10 continue + + + if (nztop.ne.1) then + do 12 h=1,nztop-1 + do 12 a=1,nrad + c(h,a,lf)=c(h,a,li) + c1(h,a,lf)=c1(h,a,li) + c2(h,a,lf)=c2(h,a,li) + caer(h,a,lf)=caer(h,a,li) +12 continue + endif + + return + end + + +*__________________________________________________________________________ + + subroutine calcoag2 + +*************************************************************** +* * +* Ce programme calcule les coefficients de collection d'une * +* particule de rayon x avec une particule de rayon b a une * +* altitude donnee h * +*************************************************************** + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2ctps/li,lf,dt + common/x2con/c,c1,c2,c3,caer + common/cldpart/rad,mmu + common/x2coag/k + common/x2frac/rfg,dfg + +* declaration des variables +* -------------------------- + + integer li,lf + real dt + real knu2,nud2,k(nz,nrad,nrad) + real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2), + & c3(nz,nrad,2) + real caer(nz,nrad,2) + real rad(nz,nrad),mmu(nz,nrad) + real rfg(nz),dfg(nz,nrad) + + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,x,ihor,i + real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg + real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb + real rfb,rfx,rpr + real*8 ne,qe,epso + real*8 corelec,yy + + real kco,vx,vb,vitesse2,sto,ee,a,dd,bb,p0,t0,l0,ccol + real st(37),ef(37) + real vitesse,knu + external vitesse,knu + + +* initialisation +* -------------- + + + +* -nombres de STOCKES + + data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1, + s 3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9, + s 10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86., + s 187.,600./ + +* -coef. d'efficacite de collection + + ef(1)=3.75 + ef(2)=8.75 + do 11 i=3,37 + ef(i)=ef(i-1)+2.5 +11 continue + + do 2 i=1,37 + ef(i)=ef(i)*1e-2 +2 continue + + qe=1.6e-19 + ne=-30e+6 + epso=1e-9/(36*pi) + + d=1.257 + e=0.4 + f=-1.1 + +* iteration sur z + + do 1 h=1,nz + + nua=nud2(h,1) + +* iteration sur les rayons + + do 1 b=1,nrad ! boucle aerosols secs : indice '' + + knb=knu(h,b,1) ! knu et vitesse se trouvent dans brume.F + vb=vitesse(h,b,1) ! ils concernent les aerosols + + do 1 x=1,nrad !boucles gouttes : indice '2' + + knx=knu2(h,x,1) + vx=vitesse2(h,x,1) + +** COAGULATION **************************************************** +** --------------**************************************************** +* calcul du terme correcteur 'slip-flow' + + alphab=d+e*exp(f/knb) + alphax=d+e*exp(f/knx) + +* calcul du coefficient de diffusion + + + rfb=(r_e(b)**(3./df(b))) *((rf(b)) **(1.-3./df(b))) + rfx=(rad(h,x)** + & (3./dfg(h,x)))*((rfg(x))**(1.-3./dfg(h,x))) + + db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb) + dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx) + +* calcul du coefficient de coagulation + + rpr=rfb+rfx + kcg=4*pi*rpr*(db+dx) + +* calcul de la vitesse thermique + + gb=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(b)**3)) + gx=sqrt(6*kbz*t(h)/(rhol*pi**2*rad(h,x)**3)) + +* calcul du libre parcours apparent des aerosols + + lambb=8*db/(pi*gb) + lambx=8*dx/(pi*gx) + +*calcul du terme correcteur beta + + rm=rpr/2. + dm=(dx+db)/2. + g=sqrt(gx**2+gb**2) + deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5) + s /(6*rfb*lambb)-2*rfb)*sqrt(2.) + deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5) + s /(6*rfx*lambx)-2*rfx)*sqrt(2.) + del=sqrt(deltab**2+deltax**2) + beta=1/((rm/(rm+del/2))+(4*dm/(g*rm))) + +* calcul du coefficient de coagulation corrige + + kcg=kcg*beta + +** COALESCENCE ************************************************** +** -------------************************************************** + + kco=0. + + if ( b.eq. x) continue ! goto 9 + + +* calcul du nombre de Stockes de la petite particule + + sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb) + +* calcul du coef. de Cunningham-Millikan + + a=1.246 + bb=0.42 + dd=0.87 + l0=0.653e-7 + p0=101325. + t0=288. + + ee=1+ + & (l0*t(h)*p0*(a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0)))) + s /(rfx*t0*p(h)) + +* calcul du nombre de Stockes corrige + + sto=sto*ee + + if (sto .le. 1.2) goto 9 + + if (sto .ge. 600.) then + ccol=1. + goto 8 + endif + +* recherche du coefficient de collection + + do 3 i=1,37 + if (sto .gt. st(i)) then + goto 3 + endif + if (sto .eq. st(i)) then + ccol=ef(i+1) + else + ccol=ef(i) + endif + goto 8 +3 continue + +* calcul du coefficient de coalescence + +8 kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx) + +9 continue + +** CORRECTION ELECTRICITE ******************************* +** ------------------------****************************** + +c yy=1.d0*ne**2*r(x)*r(b)*qe**2 +c & /(1.d0*kbz*t(h)*(r(b)+r(x))*4*pi*epso) +c corelec=0. +c if (yy.lt.50.) corelec=yy/(exp(yy)-1.) + + corelec=1. + +c b=aerosol +c x=gouttes + + k(h,b,x)=(kcg+kco)*corelec + +c +c ATTENTION, IL N'Y A PLUS DE SYMETRIE... +c k(ihor,h,x,b)=k(ihor,h,b,x) +c +c + + +1 continue + return + end + +*______________________________________________________________________ + + subroutine pertpro2(ihor,h,a,l_,pr_) + +***************************************************************************** +* * +* ce programme permet le calcul du terme de production (pr) et de perte (l)* +* pour le phenomene de coagulation * +* dans le a ieme intervalle de rayon a une altitude h * +**************************************************************************** + +* declaration des blocs communs +*------------------------------ + use dimphy + IMPLICIT NONE +#include "dimensions.h" +#include "microtab.h" +#include "varmuphy.h" + + common/x2ctps/li,lf,dt + common/x2con/c,c1,c2,c3,caer + common/cldpart/rad,mmu + common/x2coag/k + + +* declaration des variables +* -------------------------- + + integer li,lf + real dt + real dr(nrad),dv(nrad) + real k(nz,nrad,nrad) + real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2), + & c3(nz,nrad,2) + real caer(nz,nrad,2) + real rad(nz,nrad),mmu(nz,nrad) + + +* declaration des variables propres au ss-programme +* ------------------------------------------------- + + integer h,b,a,x,ihor,i + real*8 pr,ss,s,l + real pr_,l_,vol,del + +* traitement +* ----------- + + + +* production +*+++++++++++++ + s=0.d0 + ss=0.d0 + pr=0.d0 + +c Pas de production d'aerosols par scavenging !!! + + pr=0.d0 + +* perte +*- - - - - + + l=0.d0 + + + do 10 x=1,nrad ! boucle sur les gouttes + l=l+k(h,a,x)*c(h,x,li) + if(l.ne.0.d0) then + print*,a,x,k(h,a,x),c(h,x,li),l,' : detail coal' + endif + 10 continue + + +#ifdef CRAY + l_=l + pr_=pr +#else + l_=sngl(l) + pr_=sngl(pr) +#endif + + return + + end + Index: trunk/LMDZ.TITAN.old/libf/phytitan/soil.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/soil.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/soil.F (revision 1643) @@ -0,0 +1,207 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/soil.F,v 1.1.1.1 2004/05/19 12:53:09 lmdzadmin Exp $ +! + SUBROUTINE soil(ptimestep, knon, ptsrf, ptsoil, + s pcapcal, pfluxgrd) + +c======================================================================= +c +c Auteur: Frederic Hourdin 30/01/92 +c ------- +c +c objet: computation of : the soil temperature evolution +c ------ the surfacic heat capacity "Capcal" +c the surface conduction flux pcapcal +c +c +c Method: implicit time integration +c ------- +c Consecutive ground temperatures are related by: +c T(k+1) = C(k) + D(k)*T(k) (1) +c the coefficients C and D are computed at the t-dt time-step. +c Routine structure: +c 1)new temperatures are computed using (1) +c 2)C and D coefficients are computed from the new temperature +c profile for the t+dt time-step +c 3)the coefficients A and B are computed where the diffusive +c fluxes at the t+dt time-step is given by +c Fdiff = A + B Ts(t+dt) +c or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt +c with F0 = A + B (Ts(t)) +c Capcal = B*dt +c +c Interface: +c ---------- +c +c Arguments: +c ---------- +c ptimestep physical timestep (s) +c ptsrf(klon) surface temperature at time-step t (K) +c ptsoil(klon,nsoilmx) temperature inside the ground (K) +c pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) +c pfluxgrd(klon) surface diffusive flux from ground (Wm-2) +c +c======================================================================= +c declarations: +c ------------- + + use dimphy + IMPLICIT NONE +#include "YOMCST.h" +#include "dimsoil.h" +#include "clesphys.h" + +c----------------------------------------------------------------------- +c arguments +c --------- + + REAL ptimestep + INTEGER knon + REAL ptsrf(klon),ptsoil(klon,nsoilmx) + REAL pcapcal(klon),pfluxgrd(klon) + +c----------------------------------------------------------------------- +c local arrays +c ------------ + + INTEGER ig,jk + REAL zdz2(nsoilmx),z1(klon) + REAL min_period,dalph_soil + REAL ztherm_i(klon) + +c local saved variables: +c ---------------------- + REAL dz1(nsoilmx),dz2(nsoilmx) + REAL,allocatable :: zc(:,:),zd(:,:) + REAL lambda + SAVE dz1,dz2,zc,zd,lambda + LOGICAL firstcall + SAVE firstcall + + DATA firstcall/.true./ + +c----------------------------------------------------------------------- +c Depthts: +c -------- + + REAL fz,rk,fz1,rk1,rk2 + fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) + pfluxgrd(:) = 0. + + DO ig = 1, knon + ztherm_i(ig) = inertie + ENDDO + + IF (firstcall) THEN + + allocate(zc(klon,nsoilmx),zd(klon,nsoilmx)) + +c----------------------------------------------------------------------- +c ground levels +c grnd=z/l where l is the skin depth of the diurnal cycle: +c -------------------------------------------------------- + +c VENUS : A REVOIR !!!! + min_period=20000. ! en secondes + dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. + + OPEN(99,file='soil.def',status='old',form='formatted',err=9999) + READ(99,*) min_period + READ(99,*) dalph_soil + PRINT*,'Discretization for the soil model' + PRINT*,'First level e-folding depth',min_period, + s ' dalph',dalph_soil + CLOSE(99) +9999 CONTINUE + +c la premiere couche represente un dixieme de cycle diurne + fz1=sqrt(min_period/3.14) + + DO jk=1,nsoilmx + rk1=jk + rk2=jk-1 + dz2(jk)=fz(rk1)-fz(rk2) + ENDDO + DO jk=1,nsoilmx-1 + rk1=jk+.5 + rk2=jk-.5 + dz1(jk)=1./(fz(rk1)-fz(rk2)) + ENDDO + lambda=fz(.5)*dz1(1) + PRINT*,'full layers, intermediate layers (seconds)' + DO jk=1,nsoilmx + rk=jk + rk1=jk+.5 + rk2=jk-.5 + PRINT *,'fz=', + . fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14 + ENDDO + firstcall =.false. + + ELSE !--not firstcall +c----------------------------------------------------------------------- +c Computation of the soil temperatures using the Cgrd and Dgrd +c coefficient computed at the previous time-step: +c ----------------------------------------------- + +c surface temperature + DO ig=1,knon + ptsoil(ig,1)=(lambda*zc(ig,1)+ptsrf(ig))/ + s (lambda*(1.-zd(ig,1))+1.) + ENDDO + +c other temperatures + DO jk=1,nsoilmx-1 + DO ig=1,knon + ptsoil(ig,jk+1)=zc(ig,jk)+zd(ig,jk)*ptsoil(ig,jk) + ENDDO + ENDDO + + ENDIF !--not firstcall +c----------------------------------------------------------------------- +c Computation of the Cgrd and Dgrd coefficient for the next step: +c --------------------------------------------------------------- + + DO jk=1,nsoilmx + zdz2(jk)=dz2(jk)/ptimestep + ENDDO + + DO ig=1,knon + z1(ig)=zdz2(nsoilmx)+dz1(nsoilmx-1) + zc(ig,nsoilmx-1)= + $ zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig) + zd(ig,nsoilmx-1)=dz1(nsoilmx-1)/z1(ig) + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1(ig)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk) + $ *(1.-zd(ig,jk))) + zc(ig,jk-1)= + s (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk)) + $ *z1(ig) + zd(ig,jk-1)=dz1(jk-1)*z1(ig) + ENDDO + ENDDO + +c----------------------------------------------------------------------- +c computation of the surface diffusive flux from ground and +c calorific capacity of the ground: +c --------------------------------- + + DO ig=1,knon + pfluxgrd(ig)=ztherm_i(ig)*dz1(1)* + s (zc(ig,1)+(zd(ig,1)-1.)*ptsoil(ig,1)) + pcapcal(ig)=ztherm_i(ig)* + s (dz2(1)+ptimestep*(1.-zd(ig,1))*dz1(1)) + z1(ig)=lambda*(1.-zd(ig,1))+1. + pcapcal(ig)=pcapcal(ig)/z1(ig) + pfluxgrd(ig) = pfluxgrd(ig) + s + pcapcal(ig) * (ptsoil(ig,1) * z1(ig) + $ - lambda * zc(ig,1) + $ - ptsrf(ig)) + s /ptimestep + ENDDO + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/solarlong.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/solarlong.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/solarlong.F (revision 1643) @@ -0,0 +1,89 @@ + SUBROUTINE solarlong(pday,psollong) + IMPLICIT NONE + +c======================================================================= +c +c Objet: +c ------ +c +c Calcul de la distance soleil-planete et de la declinaison +c en fonction du jour de l'annee. +c +c +c Methode: +c -------- +c +c Calcul complet de l'ellipse +c +c Interface: +c ---------- +c +c Un common comprenant les parametres orbitaux. +c +c Arguments: +c ---------- +c +c Input: +c ------ +c pday jour de l'annee (le jour 0 correspondant a l'equinoxe) +c +c Output: +c ------- +c psollong Longitude solaire +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comorbit.h" + +c arguments: +c ---------- + + REAL pday,psollong + +c Local: +c ------ + + REAL zanom,xref,zx0,zdx,zteta,zz + INTEGER iter + + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c calcul de l'zanomalie moyenne + + zz=(pday-peri_day)/year_day + zanom=2.*pi*(zz-nint(zz)) + xref=abs(zanom) + +c resolution de l'equation horaire zx0 - e * sin (zx0) = xref +c methode de Newton + + zx0=xref+e_elips*sin(xref) + DO 110 iter=1,10 + zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0)) + if(abs(zdx).le.(1.e-7)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + +c zteta est la longitude solaire + + zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + + psollong=zteta-timeperi + + IF(psollong.LT.0.) psollong=psollong+2.*pi + IF(psollong.GT.2.*pi) psollong=psollong-2.*pi +c----------------------------------------------------------------------- +c sorties eventuelles: +c --------------------- + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/sources.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/sources.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/sources.F (revision 1643) @@ -0,0 +1,230 @@ + SUBROUTINE sources(ngrid,nlay, + $ ptimestep,pz0,pu,pv, + $ pplev,pzlay,pzlev, + $ gaz1,gaz2,gaz3, + $ ptsrf,evapch4,reserv) + +c======================================================================= +c Calcul des flux aux interfaces pour les sources +c CH4 a la surface +c Production de C2H6 en haut du modele. +c Production de C2H2 en haut du modele. +c +c NOTE : +c Les gaz ont la tete en haut. +c ils ne suivent pas la meme convention que muphys : +c (1 -> sol / klev = haut du modele) +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + use dimphy + IMPLICIT NONE +#include "YOMCST.h" +c +c arguments: +c ---------- + + INTEGER ngrid,nlay,nq,ihor + REAL ptimestep + REAL pplev(ngrid,nlay+1) + REAL pzlay(ngrid,nlay),pzlev(ngrid,nlay+1) + REAL pu(ngrid),pv(ngrid) + REAL gaz1(ngrid,nlay),gaz2(ngrid,nlay),gaz3(ngrid,nlay) + REAL ptsrf(ngrid) + REAL evapch4(ngrid) +c +c local: +c ------ + + INTEGER ilev,ig,ilay,nlev,k,inch4,inc2h6 + + REAL zgz1(klon,klev),zgz2(klon,klev),zgz3(klon,klev) + REAL zcdv(klon),zu2,pz0 + REAL xmair,gg,zrho,ws,ch,qch4,flux + REAL effg ! effg est une fonction(z), z en m. + REAL xmuair + REAL zmem,zmem2,zmem3 + REAL prodc2h6,prodc2h2 + real reserv(ngrid),restemp,drestemp + REAL zevapch4 + + real umin + data umin/1.e-12/ + save umin +c +c +c----------------------------------------------------------------------- +c initialisations: +c ----------------- + + nlev=nlay+1 + + if(nlay.ne.klev) THEN + PRINT*,'STOP dans sources.F' + PRINT*,'probleme de dimensions :' + PRINT*,'nlay =',nlay + PRINT*,'klev =',klev + STOP + endif + + IF(ngrid.NE.klon) THEN + PRINT*,'STOP dans sources.F' + PRINT*,'probleme de dimensions :' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + STOP + ENDIF + + zgz1 = gaz1 + zgz2 = gaz2 + zgz3 = gaz3 + + evapch4 = 0. + +c----------------------------------------------------------------------- +c 2. calcul de cd : +c ---------------- +c + DO ig=1,ngrid + zu2=pu(ig)*pu(ig)+pv(ig)*pv(ig)+umin + zcdv(ig)=pz0*(sqrt(zu2)) +c write(99,'(I4,3(ES24.17,1X))') ig, +c & pz0,zu2,(sqrt(zu2)) + ENDDO +c write(99,*) "" + +c----------------------------------------------------------------------- +c 4. Conditions aux limites pour CH4 et C2H6 +c ------------------------------------------- +c + +* Conditions CH4 + DO ig=1,ngrid + zevapch4=0. + restemp=0. + gg=effg(pzlay(ig,1)) + zrho=(pplev(ig,1)-pplev(ig,2))/gg + zrho=zrho/(pzlev(ig,2)-pzlev(ig,1)) + ws=sqrt(pu(ig)**2.+pv(ig)**2.)*(10./pzlay(ig,1))**0.2 + ch=1.5*sqrt(zcdv(ig)) + call ch4sat(ptsrf(ig),pplev(ig,1),qch4) ! qch4=kg/kg + qch4=qch4*0.50 ! ici on impose 50% d'humidité au sol + + if(reserv(ig).le. 1.e-10 ) then + flux=0. + reserv(ig)=1.e-10 + else + flux=zrho*ch*ws + flux=flux*0.1 ! fraction occupée par les lacs + endif + + zmem=zgz1(ig,1) + zgz1(ig,1)=(zgz1(ig,1)+flux*ptimestep*qch4*28./16.) + & /(1.+flux*ptimestep) + + gg=effg(pzlay(ig,1)) + xmair=(pplev(ig,1)-pplev(ig,1+1))/gg + xmair=xmair/(pzlev(ig,1+1)-pzlev(ig,1)) + xmuair=28.!*(1.-zmem)+zmem*16. + + drestemp = - (zgz1(ig,1)-zmem)*xmair ! en m3/m2=m + & *(pzlev(ig,2)-pzlev(ig,1))*16./xmuair/425. + +c ici on peut fixer un seuil sur drestemp +c (ie limiter l'echange atm/surface) + + restemp=reserv(ig) +drestemp + + IF (restemp.ge.0.) THEN + reserv(ig) = reserv(ig) + drestemp + zevapch4 = zevapch4 + drestemp + ELSE +* Il n'y a pas suffisamment de méthane; on re-évalue le flux d'évaporation +* Quelle nouvelle concentration zgz1(ig,1) atteint-on en évaporant tout ? + zgz1(ig,1)= reserv(ig)/(xmair*(pzlev(ig,1+1)-pzlev(ig,1)) + & *16./xmuair/425.)+zmem + zevapch4 = zevapch4-reserv(ig) + + if(reserv(ig).eq.0.) + & print*,'assechement du sol en ig=', ig,reserv(ig),flux + + reserv(ig)=0. ! on a tout évaporé... + ENDIF +c + evapch4(ig) = zevapch4 ! < 0 si volume évaporé (m3/m2) + + ENDDO + +* Conditions C2H6 + + prodc2h6=6.e-12/5. ! kg/m2/s + + IF (1.EQ.1) THEN + DO ig=1,ngrid + DO ilev=nlay,nlay-4,-1 +* calcule de zrho (kg/m3) pour la couche... + gg=effg(pzlay(ig,ilev)) + zrho=(pplev(ig,ilev)-pplev(ig,ilev+1))/gg + zrho=zrho/(pzlev(ig,ilev+1)-pzlev(ig,ilev)) + +* passage taux de production --> Dx_c2h6 a rajouter au niveau ilev + zmem2=zgz2(ig,ilev) + zgz2(ig,ilev)=zgz2(ig,ilev)+ + & prodc2h6*ptimestep/ + & abs(pzlev(ig,ilev+1)-pzlev(ig,ilev)) ! kg/m3/s + & /zrho*28./30. + + ENDDO + ENDDO + + ELSE + + DO ig=1,ngrid + DO ilev=nlay,nlay-8,-1 + zgz2(ig,ilev)=1.2e-5 + ENDDO + ENDDO + + ENDIF ! (fin 1.eq.0) + +*------------------------------------- +* Conditions C2H2 + + prodc2h2=1.6e-12/5. ! kg/m2/s + + IF(1 .EQ. 1) THEN + + DO ig=1,ngrid + DO ilev=nlay,nlay-4,-1 +* calcule de zrho (kg/m3) pour la couche... + gg=effg(pzlay(ig,ilev)) + zrho=(pplev(ig,ilev)-pplev(ig,ilev+1))/gg + zrho=zrho/(pzlev(ig,ilev+1)-pzlev(ig,ilev)) + +* passage taux de production --> Dx_c2h2 a rajouter au niveau ilev + zmem3=zgz3(ig,ilev) + zgz3(ig,ilev)=zgz3(ig,ilev)+ + & (prodc2h2)*ptimestep/ + & abs(pzlev(ig,ilev+1)-pzlev(ig,ilev)) ! kg/m3/s + & /zrho*28./26. + + ENDDO + + ENDDO + + ENDIF + +c----------------------------------------------------------------------- + DO ig=1,ngrid + DO ilev=1,nlay + gaz1(ig,ilev)=zgz1(ig,ilev) + gaz2(ig,ilev)=zgz2(ig,ilev) + gaz3(ig,ilev)=zgz3(ig,ilev) + ENDDO + ENDDO + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/sugwd.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/sugwd.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/sugwd.F (revision 1643) @@ -0,0 +1,185 @@ + SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay) +C +C +C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG +C +C PURPOSE. +C -------- +C INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE +C GRAVITY WAVE DRAG PARAMETRIZATION. +C VERY IMPORTANT: +C ______________ +C THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE +C VARIOUS SSO SCHEMES +C +C** INTERFACE. +C ---------- +C CALL *SUGWD* FROM *SUPHEC* +C ----- ------ +C (called not from suphec but from first call of physiq.F) +C +C EXPLICIT ARGUMENTS : +C -------------------- +C PAPRS,PPLAY : Pressure at semi and full model levels +C NLEV : number of model levels +c NLON : number of points treated in the physics +C +C IMPLICIT ARGUMENTS : +C -------------------- +C COMMON YOEGWD +C-GFRCRIT-R: Critical Non-dimensional mountain Height +C (HNC in (1), LOTT 1999) +C-GKWAKE--R: Bluff-body drag coefficient for low level wake +C (Cd in (2), LOTT 1999) +C-GRCRIT--R: Critical Richardson Number +C (Ric, End of first column p791 of LOTT 1999) +C-GKDRAG--R: Gravity wave drag coefficient +C (G in (3), LOTT 1999) +C-GKLIFT--R: Mountain Lift coefficient +C (Cl in (4), LOTT 1999) +C-GHMAX---R: Not used +C-GRAHILO-R: Set-up the trapped waves fraction +C (Beta , End of first column, LOTT 1999) +C +C-GSIGCR--R: Security value for blocked flow depth +C-NKTOPG--I: Security value for blocked flow level +C-NTOP----I: An estimate to qualify the upper levels of +C the model where one wants to impose strees +C profiles +C-GSSECC--R: Security min value for low-level B-V frequency +C-GTSEC---R: Security min value for anisotropy and GW stress. +C-GVSEC---R: Security min value for ulow +C +C +C METHOD. +C ------- +C SEE DOCUMENTATION +C +C EXTERNALS. +C ---------- +C NONE +C +C REFERENCE. +C ---------- +C Lott, 1999: Alleviation of stationary biases in a GCM through... +C Monthly Weather Review, 127, pp 788-801. +C +C AUTHOR. +C ------- +C FRANCOIS LOTT *LMD* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF) +C LAST: 99-07-09 (FRANCOIS LOTT,LMD) +C ------------------------------------------------------------------ + use dimphy + IMPLICIT NONE + +#include "YOEGWD.h" +C +C ARGUMENTS + integer nlon,nlev + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) +C + INTEGER JK + REAL ZPR,ZTOP,ZSIGT,ZPM1R + +C +C* 1. SET THE VALUES OF THE PARAMETERS +C -------------------------------- +C + 100 CONTINUE +C + PRINT *,' DANS SUGWD NLEV=',NLEV + GHMAX=10000. +C + ZPR=100000. + ZTOP=0.001 +c valeurs dans la dernière routine de FLott +c ZSIGT=0.94 +c valeurs dans les routines Mars + ZSIGT=0.85 +C +Coff CALL gather(pplay,pplay_glo) +Coff CALL bcast(pplay_glo) +Coff CALL gather(paprs,paprs_glo) +Coff CALL bcast(paprs_glo) + + DO 110 JK=1,NLEV +Coff ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) + ZPM1R=pplay(klon/2,jk)/paprs(klon/2,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF +Coff ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) + ZPM1R=pplay(klon/2,jk)/paprs(klon/2,1) + IF(ZPM1R.GE.ZTOP)THEN + ntop=JK + ENDIF + 110 CONTINUE +c +c inversion car dans orodrag on compte les niveaux a l'envers + nktopg=nlev-nktopg+1 + ntop=nlev-ntop + print *,' DANS SUGWD nktopg=', nktopg + print *,' DANS SUGWD ntop=', ntop +C + GSIGCR=0.80 +C +c valeurs dans la dernière routine de FLott +c GKDRAG=0.1875 +c GRAHILO=0.1 +c GRCRIT=1.00 +c GFRCRIT=1.00 +c GKWAKE=0.50 +C +c GKLIFT=0.25 +c GVCRIT =0.1 + +c valeurs dans les routines Mars + GKDRAG=0.1 + GRAHILO=1.0 + GRCRIT=0.25 + GFRCRIT=1.00 + GKWAKE=1.0 +C + GKLIFT=0.25 + GVCRIT =0.0 + + WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')') + WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')') + WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG + WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')') + S GRAHILO + WRITE(UNIT=6,FMT='('' Critical Richardson = '',E13.7,'' '')') + S GRCRIT + WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT + WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE + WRITE(UNIT=6,FMT='('' Low level lift cte'',e13.7)') GKLIFT + +C +C +C ---------------------------------------------------------------- +C +C* 2. SET VALUES OF SECURITY PARAMETERS +C --------------------------------- +C + 200 CONTINUE +C +c valeurs dans la dernière routine de FLott +c GVSEC=0.10 +c GSSEC=0.0001 +C +c GTSEC=0.00001 +C +c valeurs dans les routines Mars + GVSEC=0.10 + GSSEC=1.e-12 +C + GTSEC=1.e-7 +C + RETURN + END + Index: trunk/LMDZ.TITAN.old/libf/phytitan/suphec.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/suphec.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/suphec.F (revision 1643) @@ -0,0 +1,163 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/suphec.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $ +! + SUBROUTINE suphec +C +#include "YOMCST.h" +cIM cf. JLD + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + IF (firstcall) THEN + PRINT*, 'suphec initialise les constantes du GCM' + firstcall = .FALSE. + ELSE + PRINT*, 'suphec DEJA APPELE ' + RETURN + ENDIF +C ----------------------------------------------------------------- +C +C* 1. DEFINE FUNDAMENTAL CONSTANTS. +C ----------------------------- +C + WRITE(UNIT=6,FMT='(''0*** Constants of the ICM ***'')') + RPI=2.*ASIN(1.) + RCLUM=299792458. + RHPLA=6.6260755E-34 + RKBOL=1.380658E-23 + RNAVO=6.0221367E+23 + WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')') + WRITE(UNIT=6,FMT='('' PI = '',E13.7,'' -'')')RPI + WRITE(UNIT=6,FMT='('' c = '',E13.7,''m s-1'')') + S RCLUM + WRITE(UNIT=6,FMT='('' h = '',E13.7,''J s'')') + S RHPLA + WRITE(UNIT=6,FMT='('' K = '',E13.7,''J K-1'')') + S RKBOL + WRITE(UNIT=6,FMT='('' N = '',E13.7,''mol-1'')') + S RNAVO +C +C ---------------------------------------------------------------- +C +C* 2. DEFINE ASTRONOMICAL CONSTANTS. +C ------------------------------ +C +c TERRE +c RDAY=86400. +c REA=149597870000. +c REPSM=0.409093 +C +c RSIYEA=365.25*RDAY*2.*RPI/6.283076 +c 1/(duree du jour) = 1/(periode rotation) - 1/(periode revolution) +c RSIDAY=RDAY/(1.+RDAY/RSIYEA) +c ROMEGA=2.*RPI/RSIDAY + +c TITAN + RSIYEA=9.28e8 ! 673 jTitan +c LEQUEL DES 2 ?? A VERIFIER !! +c RSIDAY=1.37889e6 ! 15.96 j + RDAY=1.37889e6 ! 15.96 j +c 1/(duree du jour) = 1/(periode rotation) - 1/(periode revolution) +c RDAY=RSIDAY/(1.-RSIDAY/RSIYEA) + RSIDAY=RDAY/(1.+RDAY/RSIYEA) + ROMEGA=2.*RPI/RSIDAY + REA=1.5e12 + REPSM=0. ! 0. veut dire qu'on commence au point vernal +c +cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90 + + WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')') + WRITE(UNIT=6,FMT='('' day = '',E13.7,'' s'')')RDAY + WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA + WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM + WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA + WRITE(UNIT=6,FMT='('' sideral day = '',E13.7,'' s'')')RSIDAY + WRITE(UNIT=6,FMT='('' omega = '',E13.7,'' s-1'')') + S ROMEGA +C +C ------------------------------------------------------------------ +C +C* 3. DEFINE GEOIDE. +C -------------- +C +c TERRE +c RG=9.80665 +c RA=6371229. + +c VENUS +c RG=8.87 +c RA=6051300. + +c TITAN + RG=1.35 + RA=2575000. + + R1SA=SNGL(1.D0/DBLE(RA)) + WRITE(UNIT=6,FMT='('' *** Geoide ***'')') + WRITE(UNIT=6,FMT='('' Gravity = '',E13.7,'' m s-2'')') + S RG + WRITE(UNIT=6,FMT='('' Planet radius = '',E13.7,'' m'')')RA + WRITE(UNIT=6,FMT='('' Inverse P.R. = '',E13.7,'' m-1'')')R1SA +C +C ----------------------------------------------------------------- +C +C* 4. DEFINE RADIATION CONSTANTS. +C --------------------------- +C +c z.x.li RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3) + rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15. +cIM init. dans conf_phys.F90 RI0=1365. + WRITE(UNIT=6,FMT='('' *** Radiation ***'')') + WRITE(UNIT=6,FMT='('' Stefan-Bol. = '',E13.7,'' W m-2 K-4'' + S )') RSIGMA +cIM init. dans conf_phys.F90 WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')') +cIM init. dans conf_phys.F90 S RI0 +C +C ----------------------------------------------------------------- +C +C* 5. DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE. +C ------------------------------------------ +C + R=RNAVO*RKBOL +c TERRE +c RMD=28.9644 + RMV=18.0153 + +c VENUS + RMD=43.44 + +c TITAN + RMD=28. + + RD=1000.*R/RMD + RV=1000.*R/RMV +c TERRE +c RCPD=3.5*RD + RCPV=4. *RV +c VENUS +! ADAPTATION GCM POUR CP(T) +! VENUS: Cp(T) = RCPD*(T/T0)^nu (RCPD phys = cpp dyn) +! avec RCPD=1000., T0=460. et nu=0.35 +! RCPD=1.0e3 +! RCPD=9.0e2 ! Version constante +c TITAN + RCPD=1.039e3 + RCVD=RCPD-RD + RCVV=RCPV-RV + RKAPPA=RD/RCPD + RETV=RV/RD-1. + WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas ***'')') + WRITE(UNIT=6,FMT='('' Perfect gas = '',e13.7)') R + WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD + WRITE(UNIT=6,FMT='('' Vapour mass = '',e13.7)') RMV + WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD + WRITE(UNIT=6,FMT='('' Vapour cst. = '',e13.7)') RV + WRITE(UNIT=6,FMT='('' Cpd0 = '',e13.7)') RCPD + WRITE(UNIT=6,FMT='('' Cvd = '',e13.7)') RCVD + WRITE(UNIT=6,FMT='('' Cpv = '',e13.7)') RCPV + WRITE(UNIT=6,FMT='('' Cvv = '',e13.7)') RCVV + WRITE(UNIT=6,FMT='('' Rd/Cpd0 = '',e13.7)') RKAPPA + WRITE(UNIT=6,FMT='('' Rv/Rd-1 = '',e13.7)') RETV +C + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/tabcontrol.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/tabcontrol.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/tabcontrol.h (revision 1643) @@ -0,0 +1,17 @@ +!------------------------------------------------------------------- +! INCLUDE tabcontrol.h +!------------------------------------------------------------------- + + INTEGER radpas,chimpas ! frequences d'appel rayonnement, chimie + REAL dtime ! pas temporel de la physique + REAL lsinit ! Solar longitude in the startphy file + +! tableau de controle + INTEGER length + PARAMETER ( length = 100 ) + REAL tabcntr0( length ) + + + COMMON/ctltab_i/radpas,chimpas + COMMON/ctltab_r/dtime,lsinit + COMMON/ctltab/tabcntr0 Index: trunk/LMDZ.TITAN.old/libf/phytitan/tgmdat_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/tgmdat_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/tgmdat_mod.F90 (revision 1643) @@ -0,0 +1,43 @@ +MODULE TGMDAT_MOD + IMPLICIT NONE + + REAL,SAVE :: PI=3.14159265358979323846 +! RGAS IS THE UNIVERSAL GAS CONSTANT IN UNITS OF: M SEC-2 AMU K-1 KM + REAL,SAVE :: RGAS=8.31432 +! SIGMA IS THE STEFAN-BOLTZMAN CONSTATNT IN CGS UNITS + REAL,SAVE :: SIGMA=5.6677E-5 +! +! RT CONSTANTS + REAL,SAVE :: UBARI=0.5,UBARV=0.5,UBAR0=0.5 +! PLANET SPECIFIC CONSTANTS +! +! CONVEQ IS THE DRY N2 ADIABATE DLNT/DLNP + REAL,SAVE :: CONVEQ=0.2994 +! CSUBP IS THE SPECIFIC HEAT AT CONSTANT P OF THE ATMOSPHERE +! IN UNITS OF ERGS K-1 G-1 + REAL,SAVE :: CSUBP=1.039E7 +! RHOP IS THE UNITS CONVERSION FROM TO GET MASS UNITS (G CM-2) +! FROM PRESSURE (BARS) DEVIDED BY GRAVITY (M SEC-2) +! IS EQUAL TO ONE GM CM-2 BARS-1 M SEC-2 +! IF ONE WHATS TO CHANGE UNITS ON PRESSURE THIS +! CONSTANT MUST BE CHANGED + REAL,SAVE :: RHOP=1.E4 +! FOPI IS THE ACTUAL SOLAR FLUX IN ERGS/CM2 + REAL,SAVE :: F0PI=1.5E4 +! RHCH4 IS THE METHANE RH AT THE SURFACE + REAL,SAVE :: RHCH4=0.60 !! .65 +! FH2 IS THE CONSTANT MIXING RATIO OF H2 + REAL,SAVE :: FH2=0.04 !! 0.003 +! FHAZE IS THE HAZE PRODUCTION SCALING FACTOR + REAL,SAVE :: FHAZE=0.35 +! FHIR IS THE HAZE INFRARED ABSORPTION SCALE FACTOR + REAL,SAVE :: FHIR=0.7 ! anciennement 0.5 +! FHVIS IS THE HAZE INFRARED ABSORPTION SCALE FACTOR + REAL,SAVE :: FHVIS=1.1 !!!! 1.333333333/ +! TAUFAC IS THE 200 CM-1 SCALING FACTOR + REAL,SAVE :: TAUFAC=2.00 +! RCLOUD IS THE PARTICLE SIZE IN THE CLOUD IN MICRONS + REAL,SAVE ::RCLOUD=60. !! 100 + + REAL,SAVE :: FARGON=0. +END MODULE TGMDAT_MOD Index: trunk/LMDZ.TITAN.old/libf/phytitan/tholin.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/tholin.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/tholin.F (revision 1643) @@ -0,0 +1,56 @@ + SUBROUTINE THOLIN(WAVELN,XNR,XNI) + DIMENSION W(90),XN(90),XK(90) + DATA W/ + &920.0000,850.0000,774.9000,688.8000,563.5000,387.4000,229.6000, + &172.2000,140.9000,121.5000, 81.5700, 56.3500, 36.4600, 31.0000, + & 22.1400, 18.2300, 17.7100, 14.4200, 12.9100, 11.7000, 11.0700, + & 10.5100, 8.7310, 7.6530, 7.0440, 6.6660, 6.4570, 6.3260, + & 5.9610, 5.8480, 5.7400, 5.4380, 5.2530, 5.1660, 4.8810, + & 4.6260, 4.5920, 4.4920, 4.4280, 4.2170, 3.9480, 3.6680, + & 3.4630, 3.2460, 3.0090, 2.9380, 2.8180, 2.7430, 2.6950, + & 2.4220, 2.4030, 2.3930, 2.2140, 2.0190, 1.8730, 1.8230, + & 1.8130, 1.8020, 1.3810, 1.3570, 1.1920, 1.1480, 1.0160, + & 0.8731, 0.6888, 0.5635, 0.4428, 0.4133, 0.3874, 0.3542, + & 0.3263, 0.2952, 0.2638, 0.2384, 0.1968, 0.1631, 0.1362, + & 0.1215, 0.1181, 0.1159, 0.1097, 0.1016, 0.0925, 0.0800, + & 0.0785, 0.0588, 0.0449, 0.0415, 0.0312, 0.0207/ + DATA XN/ + &2.170,2.170,2.160,2.160,2.150,2.120,2.070,2.040,2.030,2.020,1.930, + &1.860,1.810,1.810,1.800,1.760,1.740,1.670,1.670,1.640,1.660,1.670, + &1.710,1.720,1.690,1.690,1.640,1.580,1.430,1.440,1.480,1.550,1.580, + &1.580,1.610,1.620,1.610,1.610,1.610,1.630,1.640,1.650,1.650,1.650, + &1.610,1.590,1.580,1.590,1.600,1.620,1.620,1.620,1.630,1.630,1.630, + &1.640,1.640,1.640,1.640,1.640,1.650,1.650,1.650,1.660,1.680,1.700, + &1.720,1.690,1.660,1.630,1.640,1.660,1.680,1.680,1.660,1.650,1.700, + &1.740,1.750,1.750,1.720,1.670,1.580,1.370,1.330,0.963,0.812,0.802, + &0.850,0.920/ + DATA XK/ + &3.0E-3,1.0E-2,2.9E-2,4.7E-2,7.0E-2,1.0E-1,1.4E-1,1.6E-1,1.6E-1, + &1.9E-1,2.1E-1,1.9E-1,1.5E-1,1.4E-1,1.8E-1,2.1E-1,2.1E-1,1.7E-1, + &1.4E-1,9.7E-2,7.9E-2,7.5E-2,9.2E-2,1.3E-1,1.7E-1,2.2E-1,2.6E-1, + &2.8E-1,1.5E-1,7.0E-2,2.9E-2,1.1E-2,8.7E-3,7.6E-3,1.0E-2,2.7E-2, + &2.8E-2,1.4E-2,1.1E-2,1.0E-2,1.3E-2,2.1E-2,3.5E-2,5.6E-2,7.5E-2, + &6.0E-2,2.4E-2,1.1E-2,4.1E-3,1.2E-3,8.5E-4,8.0E-4,8.9E-4,7.2E-4, + &5.2E-4,4.4E-4,4.2E-4,4.0E-4,4.1E-4,4.2E-4,5.2E-4,6.4E-4,1.0E-3, + &2.4E-3,8.8E-3,2.3E-2,6.0E-2,7.6E-2,9.1E-2,1.1E-1,1.3E-1,1.5E-1, + &1.8E-1,2.1E-1,2.2E-1,2.4E-1,2.7E-1,3.7E-1,4.0E-1,4.3E-1,5.0E-1, + &5.8E-1,6.7E-1,7.7E-1,7.7E-1,6.2E-1,3.8E-1,3.1E-1,1.4E-1,4.9E-2/ + XNR=XN(1) + XNI=XK(1) + IF (WAVELN .GT. W(1)) RETURN + XNR=XN(90) + XNI=XK(90) + IF (WAVELN .LT. W(90)) RETURN + DO 100 I=2,90 + IF (WAVELN .GT. W(I) ) GO TO 101 + 100 CONTINUE + 101 CONTINUE +C ALL INTERPOLATION IS IN LOG LAMBDA + FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I))) +C REAL PART IS LINEARLY INTERPOLATED + XNR=XN(I) + FACTOR*(XN(I-1) - XN(I)) +C IMAGINARY PART IS LOG INTERPOLATED + XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I))) + XNI=exp(XNI) + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/tholin_cvd.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/tholin_cvd.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/tholin_cvd.F (revision 1643) @@ -0,0 +1,200 @@ + SUBROUTINE THOLIN_CVD(WLNMETERS,XNR,XNI) ! original +C THIS ROUTINE RETURNS THE OPTICAL CONSTANTS OF LABORATORY PRODUCED +C FOR WAVELN ABOVE AND BELOW THE DATA, VALUES ARE EXTRAPOLATED AS +CONSTANT + DIMENSION W(385),XN(385),XK(385) + + data W/ + &314.0367,303.2380,292.8110,282.7425,273.0199,263.6319,254.5665, + &245.8130,237.3603,229.3791,225.0075,220.7190,216.5123,212.3858, + &208.3380,204.3672,200.4722,196.6515,192.9034,189.2269,185.6204, + &182.0827,178.6123,175.2082,171.9691,169.6769,167.4153,165.1838, + &162.9822,160.8098,158.6664,156.5516,154.4649,152.4061,150.3746, + &148.3703,146.3927,144.4415,142.5163,140.6907,139.3035,137.9300, + &136.5701,135.2235,133.8902,132.5701,131.2629,129.9687,128.6872, + &127.4184,126.1621,124.9181,123.6865,122.4669,120.8540,117.6756, + &114.5806,111.5671,108.6329,105.7758,102.9938,100.2851, 97.6476, + & 95.0794, 92.5788, 90.1439, 87.7731, 85.4646, 83.2169, 81.0670, + & 79.0859, 77.1533, 75.2678, 73.4285, 71.6340, 69.8835, 68.1757, + & 66.5097, 64.8843, 63.2987, 61.7519, 60.2428, 58.7706, 57.3344, + & 55.8598, 54.2566, 52.6993, 51.1868, 49.7176, 48.2906, 46.9046, + & 45.5584, 44.2508, 42.9807, 41.7471, 40.5489, 39.3851, 38.2547, + & 37.1567, 36.3218, 35.9298, 35.5420, 35.1584, 34.7789, 34.4036, + & 34.0323, 33.6650, 33.3016, 32.9422, 32.5867, 32.2350, 31.8871, + & 31.5429, 31.2025, 30.7221, 30.0381, 29.3693, 28.7155, 28.0761, + & 27.4511, 26.8399, 26.2424, 25.6581, 25.0869, 24.5283, 23.9823, + & 23.4483, 22.9263, 22.4159, 22.0109, 21.7266, 21.4461, 21.1691, + & 20.8957, 20.6259, 20.3595, 20.0966, 19.8371, 19.5809, 19.3281, + & 19.0785, 18.8321, 18.5889, 18.3489, 18.2124, 18.1771, 18.1420, + & 18.1069, 18.0719, 18.0369, 18.0021, 17.9672, 17.9325, 17.8978, + & 17.8632, 17.8287, 17.7942, 17.7598, 17.7254, 17.5766, 17.3366, + & 17.0999, 16.8665, 16.6362, 16.4091, 16.1851, 15.9641, 15.7461, + & 15.5312, 15.3191, 15.1100, 14.9037, 14.7002, 14.4995, 14.3561, + & 14.2503, 14.1453, 14.0410, 13.9375, 13.8347, 13.7327, 13.6315, + & 13.5310, 13.4313, 13.3323, 13.2340, 13.1364, 13.0396, 12.9435, + & 12.8549, 12.7705, 12.6867, 12.6035, 12.5208, 12.4387, 12.3570, + & 12.2760, 12.1954, 12.1154, 12.0359, 11.9569, 11.8785, 11.8006, + & 11.7231, 11.6697, 11.6266, 11.5836, 11.5408, 11.4982, 11.4557, + & 11.4133, 11.3712, 11.3291, 11.2873, 11.2456, 11.2040, 11.1626, + & 11.1213, 11.0803, 11.0412, 11.0029, 10.9648, 10.9268, 10.8889, + & 10.8512, 10.8136, 10.7761, 10.7387, 10.7015, 10.6644, 10.6274, + & 10.5906, 10.5539, 10.5173, 10.4062, 10.2779, 10.1512, 10.0261, + & 9.9025, 9.7804, 9.6598, 9.5407, 9.4231, 9.3070, 9.1922, + & 9.0789, 8.9670, 8.8564, 8.7473, 8.6658, 8.5898, 8.5144, + & 8.4397, 8.3656, 8.2922, 8.2194, 8.1473, 8.0758, 8.0049, + & 7.9346, 7.8650, 7.7960, 7.7276, 7.6597, 7.6149, 7.5728, + & 7.5309, 7.4892, 7.4478, 7.4066, 7.3656, 7.3249, 7.2844, + & 7.2441, 7.2040, 7.1642, 7.1246, 7.0851, 7.0460, 7.0194, + & 6.9935, 6.9678, 6.9421, 6.9165, 6.8911, 6.8657, 6.8404, + & 6.8152, 6.7901, 6.7651, 6.7402, 6.7154, 6.6906, 6.6660, + & 5.7876, 5.4343, 5.1027, 4.7912, 4.4988, 4.2242, 3.9664, + & 3.7243, 3.4970, 3.2836, 3.0832, 2.8950, 2.7183, 2.5524, + & 2.3966, 2.2504, 2.1130, 1.9841, 1.8630, 1.7493, 1.6425, + & 1.5422, 1.4481, 1.3597, 1.2767, 1.1988, 1.1257, 1.0570, + & 0.9924, 0.9319, 0.8750, 0.8216, 0.7715, 0.7244, 0.6802, + & 0.6386, 0.5997, 0.5631, 0.5287, 0.4964, 0.4661, 0.4377, + & 0.4110, 0.3859, 0.3623, 0.3402, 0.3195, 0.3000, 0.2817, + & 0.2645, 0.2483, 0.2332, 0.2189, 0.2056, 0.1930, 0.1812, + & 0.1702, 0.1598, 0.1500, 0.1409, 0.1323, 0.1242, 0.1166, + & 0.1095, 0.1028, 0.0966, 0.0907, 0.0851, 0.0799, 0.0751, + & 0.0705, 0.0662, 0.0621, 0.0583, 0.0548, 0.0514, 0.0483, + & 0.0453, 0.0426, 0.0400, 0.0375, 0.0353, 0.0331, 0.0311, + & 0.0292, 0.0274, 0.0257, 0.0242, 0.0227, 0.0213, 0.0200/ + + data XN/ + & 1.9168, 1.9212, 1.9258, 1.9306, 1.9353, 1.9397, 1.9428, + & 1.9421, 1.9430, 1.9444, 1.9454, 1.9469, 1.9476, 1.9474, + & 1.9463, 1.9439, 1.9387, 1.9312, 1.9260, 1.9210, 1.9160, + & 1.9101, 1.9037, 1.8982, 1.8931, 1.8894, 1.8856, 1.8818, + & 1.8779, 1.8738, 1.8693, 1.8646, 1.8593, 1.8530, 1.8475, + & 1.8423, 1.8369, 1.8314, 1.8247, 1.8189, 1.8149, 1.8112, + & 1.8076, 1.8040, 1.8003, 1.7964, 1.7930, 1.7901, 1.7874, + & 1.7849, 1.7826, 1.7805, 1.7785, 1.7768, 1.7745, 1.7715, + & 1.7688, 1.7652, 1.7613, 1.7574, 1.7535, 1.7490, 1.7442, + & 1.7399, 1.7363, 1.7337, 1.7317, 1.7308, 1.7283, 1.7248, + & 1.7198, 1.7164, 1.7132, 1.7066, 1.7027, 1.7001, 1.6959, + & 1.6923, 1.6897, 1.6877, 1.6859, 1.6847, 1.6840, 1.6835, + & 1.6831, 1.6839, 1.6875, 1.6914, 1.6930, 1.6934, 1.6951, + & 1.6949, 1.6925, 1.6932, 1.6943, 1.6962, 1.6976, 1.6983, + & 1.6997, 1.7005, 1.7008, 1.7012, 1.7018, 1.7024, 1.7028, + & 1.7032, 1.7037, 1.7044, 1.7051, 1.7055, 1.7058, 1.7061, + & 1.7066, 1.7064, 1.7044, 1.7014, 1.7018, 1.7014, 1.7019, + & 1.7027, 1.7029, 1.7060, 1.7076, 1.7074, 1.7083, 1.7091, + & 1.7106, 1.7116, 1.7096, 1.7104, 1.7114, 1.7112, 1.7114, + & 1.7120, 1.7116, 1.7121, 1.7144, 1.7165, 1.7159, 1.7126, + & 1.7098, 1.7112, 1.7108, 1.7105, 1.7115, 1.7117, 1.7119, + & 1.7121, 1.7121, 1.7121, 1.7121, 1.7120, 1.7120, 1.7119, + & 1.7118, 1.7117, 1.7117, 1.7116, 1.7116, 1.7116, 1.7118, + & 1.7121, 1.7127, 1.7135, 1.7152, 1.7170, 1.7164, 1.7131, + & 1.7127, 1.7140, 1.7158, 1.7193, 1.7226, 1.7255, 1.7276, + & 1.7285, 1.7293, 1.7297, 1.7298, 1.7295, 1.7285, 1.7270, + & 1.7243, 1.7193, 1.7132, 1.7094, 1.7064, 1.7033, 1.7016, + & 1.7010, 1.7015, 1.7032, 1.7037, 1.7040, 1.7040, 1.7039, + & 1.7037, 1.7035, 1.7032, 1.7029, 1.7026, 1.7023, 1.7019, + & 1.7015, 1.7013, 1.7011, 1.7009, 1.7008, 1.7006, 1.7003, + & 1.6998, 1.6992, 1.6986, 1.6977, 1.6964, 1.6955, 1.6949, + & 1.6944, 1.6940, 1.6936, 1.6933, 1.6930, 1.6927, 1.6925, + & 1.6923, 1.6922, 1.6921, 1.6920, 1.6919, 1.6918, 1.6918, + & 1.6917, 1.6917, 1.6917, 1.6918, 1.6921, 1.6926, 1.6933, + & 1.6942, 1.6953, 1.6966, 1.6981, 1.6999, 1.7020, 1.7048, + & 1.7082, 1.7107, 1.7131, 1.7153, 1.7171, 1.7187, 1.7204, + & 1.7221, 1.7240, 1.7259, 1.7278, 1.7312, 1.7359, 1.7411, + & 1.7464, 1.7494, 1.7514, 1.7526, 1.7522, 1.7499, 1.7421, + & 1.7382, 1.7424, 1.7539, 1.7647, 1.7797, 1.8034, 1.7889, + & 1.7552, 1.7328, 1.7341, 1.7439, 1.7669, 1.7864, 1.7968, + & 1.8076, 1.8169, 1.8204, 1.8160, 1.7935, 1.7718, 1.7534, + & 1.7302, 1.6941, 1.6947, 1.7192, 1.7730, 1.8033, 1.7930, + & 1.4623, 1.5506, 1.5865, 1.6135, 1.6100, 1.6293, 1.6393, + & 1.6479, 1.6500, 1.6500, 1.6229, 1.5865, 1.5951, 1.6102, + & 1.6200, 1.6279, 1.6300, 1.6300, 1.6320, 1.6400, 1.6400, + & 1.6400, 1.6400, 1.6400, 1.6447, 1.6496, 1.6500, 1.6500, + & 1.6515, 1.6557, 1.6599, 1.6651, 1.6704, 1.6758, 1.6813, + & 1.6875, 1.6938, 1.7001, 1.7053, 1.7105, 1.7157, 1.7149, + & 1.6874, 1.6587, 1.6376, 1.6349, 1.6442, 1.6568, 1.6684, + & 1.6796, 1.6800, 1.6777, 1.6711, 1.6645, 1.6590, 1.6556, + & 1.6523, 1.6557, 1.6731, 1.6906, 1.7102, 1.7323, 1.7500, + & 1.7189, 1.6778, 1.6211, 1.5510, 1.4599, 1.3682, 1.2730, + & 1.1930, 1.1130, 1.0330, 0.9586, 0.9234, 0.8881, 0.8528, + & 0.8176, 0.8053, 0.8083, 0.8189, 0.8295, 0.8401, 0.8507, + & 0.8614, 0.8721, 0.8829, 0.8936, 0.9044, 0.9151, 0.9200/ + + data XK/ + &.139E-01,.173E-01,.214E-01,.266E-01,.330E-01,.409E-01,.507E-01, + &.601E-01,.676E-01,.759E-01,.810E-01,.869E-01,.942E-01,.102E+00, + &.111E+00,.120E+00,.130E+00,.135E+00,.140E+00,.145E+00,.150E+00, + &.155E+00,.159E+00,.162E+00,.165E+00,.167E+00,.170E+00,.172E+00, + &.174E+00,.177E+00,.180E+00,.182E+00,.185E+00,.186E+00,.187E+00, + &.188E+00,.188E+00,.189E+00,.190E+00,.188E+00,.187E+00,.186E+00, + &.185E+00,.184E+00,.183E+00,.181E+00,.179E+00,.177E+00,.175E+00, + &.173E+00,.171E+00,.169E+00,.167E+00,.165E+00,.163E+00,.158E+00, + &.156E+00,.154E+00,.152E+00,.150E+00,.148E+00,.146E+00,.143E+00, + &.140E+00,.137E+00,.133E+00,.130E+00,.128E+00,.128E+00,.127E+00, + &.126E+00,.123E+00,.123E+00,.120E+00,.115E+00,.112E+00,.109E+00, + &.104E+00,.989E-01,.939E-01,.890E-01,.841E-01,.792E-01,.747E-01, + &.695E-01,.627E-01,.571E-01,.552E-01,.546E-01,.528E-01,.513E-01, + &.523E-01,.488E-01,.452E-01,.423E-01,.401E-01,.391E-01,.376E-01, + &.363E-01,.356E-01,.351E-01,.347E-01,.342E-01,.341E-01,.340E-01, + &.337E-01,.334E-01,.332E-01,.335E-01,.338E-01,.342E-01,.344E-01, + &.351E-01,.362E-01,.379E-01,.356E-01,.333E-01,.322E-01,.300E-01, + &.294E-01,.270E-01,.258E-01,.271E-01,.273E-01,.267E-01,.268E-01, + &.265E-01,.289E-01,.288E-01,.274E-01,.280E-01,.285E-01,.282E-01, + &.286E-01,.287E-01,.274E-01,.273E-01,.296E-01,.334E-01,.351E-01, + &.327E-01,.311E-01,.319E-01,.301E-01,.300E-01,.300E-01,.302E-01, + &.304E-01,.307E-01,.309E-01,.310E-01,.311E-01,.311E-01,.312E-01, + &.312E-01,.312E-01,.312E-01,.311E-01,.311E-01,.309E-01,.305E-01, + &.302E-01,.299E-01,.296E-01,.292E-01,.316E-01,.345E-01,.344E-01, + &.322E-01,.304E-01,.293E-01,.286E-01,.305E-01,.326E-01,.355E-01, + &.378E-01,.403E-01,.430E-01,.461E-01,.493E-01,.528E-01,.565E-01, + &.604E-01,.646E-01,.636E-01,.621E-01,.607E-01,.587E-01,.556E-01, + &.528E-01,.503E-01,.494E-01,.495E-01,.496E-01,.496E-01,.497E-01, + &.498E-01,.499E-01,.499E-01,.500E-01,.501E-01,.501E-01,.502E-01, + &.503E-01,.503E-01,.504E-01,.504E-01,.506E-01,.509E-01,.512E-01, + &.515E-01,.518E-01,.521E-01,.525E-01,.522E-01,.516E-01,.510E-01, + &.504E-01,.498E-01,.493E-01,.488E-01,.483E-01,.477E-01,.472E-01, + &.467E-01,.462E-01,.457E-01,.453E-01,.448E-01,.443E-01,.438E-01, + &.434E-01,.429E-01,.424E-01,.411E-01,.395E-01,.380E-01,.365E-01, + &.351E-01,.338E-01,.324E-01,.312E-01,.300E-01,.288E-01,.277E-01, + &.281E-01,.289E-01,.297E-01,.305E-01,.311E-01,.317E-01,.323E-01, + &.329E-01,.336E-01,.342E-01,.342E-01,.337E-01,.348E-01,.365E-01, + &.415E-01,.475E-01,.529E-01,.589E-01,.656E-01,.705E-01,.744E-01, + &.645E-01,.558E-01,.515E-01,.532E-01,.550E-01,.806E-01,.121E+00, + &.139E+00,.112E+00,.921E-01,.777E-01,.696E-01,.819E-01,.914E-01, + &.102E+00,.121E+00,.145E+00,.173E+00,.199E+00,.204E+00,.208E+00, + &.213E+00,.190E+00,.147E+00,.114E+00,.111E+00,.157E+00,.220E+00, + &.428E-01,.109E-01,.807E-02,.141E-01,.147E-01,.100E-01,.128E-01, + &.190E-01,.321E-01,.252E-01,.273E-01,.124E-01,.719E-02,.719E-02, + &.719E-02,.719E-02,.719E-02,.719E-02,.719E-02,.719E-02,.719E-02, + &.718E-02,.709E-02,.701E-02,.720E-02,.699E-02,.759E-02,.723E-02, + &.694E-02,.723E-02,.777E-02,.864E-02,.102E-01,.126E-01,.160E-01, + &.204E-01,.264E-01,.346E-01,.435E-01,.551E-01,.701E-01,.889E-01, + &.109E+00,.129E+00,.147E+00,.168E+00,.188E+00,.205E+00,.226E+00, + &.250E+00,.275E+00,.294E+00,.299E+00,.303E+00,.309E+00,.318E+00, + &.328E+00,.339E+00,.353E+00,.368E+00,.407E+00,.484E+00,.584E+00, + &.698E+00,.788E+00,.873E+00,.950E+00,.101E+01,.107E+01,.104E+01, + &.988E+00,.942E+00,.899E+00,.850E+00,.758E+00,.676E+00,.603E+00, + &.538E+00,.461E+00,.389E+00,.326E+00,.274E+00,.230E+00,.193E+00, + &.164E+00,.140E+00,.119E+00,.101E+00,.861E-01,.733E-01,.681E-01/ + + XNR=XN(1) + XNI=XK(1) + WAVELN = WLNMETERS !* 1.E6 ! ARRAYS ARE IN MICRONS + IF (WAVELN .GE. W(1)) RETURN + XNR=XN(385) + XNI=XK(385) + IF (WAVELN .LE. W(385)) RETURN + DO 100 I=2,384 + IF (WAVELN .GT. W(I) ) GOTO 101 + 100 CONTINUE + 101 CONTINUE +C ALL INTERPOLATION IS IN LOG LAMBDA + FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I))) +C REAL PART IS LINEARLY INTERPOLATED + XNR=XN(I) + FACTOR*(XN(I-1) - XN(I)) +C IMAGINARY PART IS LOG INTERPOLATED + XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I))) + XNI=exp(XNI) + + RETURN + END + + Index: trunk/LMDZ.TITAN.old/libf/phytitan/time_phylmdz_mod.F90 =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/time_phylmdz_mod.F90 (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/time_phylmdz_mod.F90 (revision 1643) @@ -0,0 +1,47 @@ +MODULE time_phylmdz_mod + + IMPLICIT NONE + REAL,SAVE :: pdtphys ! physics time step (s) +!$OMP THREADPRIVATE(pdtphys) + INTEGER,SAVE :: nday ! number of days to run +!$OMP THREADPRIVATE(nday) + INTEGER,SAVE :: annee_ref ! reference year from the origin +!$OMP THREADPRIVATE(annee_ref) + INTEGER,SAVE :: day_ref ! reference day of the origin +!$OMP THREADPRIVATE(day_ref) + INTEGER,SAVE :: day_ini ! initial day of the run since first day of annee_ref +!$OMP THREADPRIVATE(day_ini) + INTEGER,SAVE :: day_end ! final day of the run since first day of annee_ref +!$OMP THREADPRIVATE(day_end) + INTEGER,SAVE :: raz_date ! flag to reset date (0:no, 1:yes) +!$OMP THREADPRIVATE(raz_date) + INTEGER,SAVE :: itau_phy ! number of physics iterations +!$OMP THREADPRIVATE(itau_phy) + +CONTAINS + + SUBROUTINE init_time(annee_ref_, day_ref_, day_ini_, day_end_, & + nday_, pdtphys_) + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + INTEGER,INTENT(IN) :: annee_ref_ + INTEGER,INTENT(IN) :: day_ref_ + INTEGER,INTENT(IN) :: day_ini_ + INTEGER,INTENT(IN) :: day_end_ + INTEGER,INTENT(IN) :: nday_ + REAL,INTENT(IN) :: pdtphys_ + + annee_ref=annee_ref_ + day_ref=day_ref_ + day_ini=day_ini_ + day_end=day_end_ + nday=nday_ + pdtphys=pdtphys_ + + ! Initialize module variable not inherited from dynamics + raz_date = 0 ! default value + CALL getin_p('raz_date', raz_date) + + END SUBROUTINE init_time + +END MODULE time_phylmdz_mod Index: trunk/LMDZ.TITAN.old/libf/phytitan/ustarhb.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/ustarhb.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/ustarhb.F (revision 1643) @@ -0,0 +1,50 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ustarhb.F,v 1.1 2004/06/22 11:45:35 lmdzadmin Exp $ +! + SUBROUTINE ustarhb(knon,u,v,cd_m, ustar) +c====================================================================== +c Laurent Li (LMD/CNRS), le 30 septembre 1998 +c Couche limite non-locale. Adaptation du code du CCM3. +c Code non teste, donc a ne pas utiliser. +c====================================================================== +c Nonlocal scheme that determines eddy diffusivities based on a +c diagnosed boundary layer height and a turbulent velocity scale. +c Also countergradient effects for heat and moisture are included. +c +c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: +c Local versus nonlocal boundary-layer diffusion in a global climate +c model. J. of Climate, vol. 6, 1825-1842. +c====================================================================== + use dimphy + IMPLICIT none +#include "YOMCST.h" +c +c Arguments: +c + INTEGER knon ! nombre de points a calculer + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL cd_m(klon) ! coefficient de friction au sol pour vitesse + REAL ustar(klon) +c + INTEGER i, k + REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal +c + DO i = 1, knon + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 + zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 + zxmod = SQRT(zxu**2+zxv**2) + taux = zxu *zxmod*cd_m(i) + tauy = zxv *zxmod*cd_m(i) + ustar(i) = SQRT(taux**2+tauy**2) +c print*,'Ust ',zxu,zxmod,taux,ustar(i) + ENDDO +c + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/varmuphy.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/varmuphy.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/varmuphy.h (revision 1643) @@ -0,0 +1,36 @@ +!*********************************************************************** +! varmuphy.h : +! fichier contenant toutes les variables communes a la microphysique. +! Necessite microtab.h (pour la definition de nrad). +! NOTE : certaines variables restent spécifiques a seulement quelques +! une des routines de la microphysique. +!*********************************************************************** +!*********************************************************************** +! variables communes a tous les routines +!*********************************************************************** + real p(llm),t(llm),rho(llm),pb(llm+1),tb(llm+1),rhob(llm+1) + real ach4(llm),aar(llm),an2(llm) !var communes a brume.F et snuages.F + real z(llm),dz(llm),zb(llm+1),dzb(llm+1) + real v_e(nrad),r_e(nrad),vrat_e,dr_e(nrad),dv_e(nrad) + + common/grille/z,zb,dz,dzb + common/donnees/p,pb,t,tb,rho,rhob,ach4,aar,an2 + common/aergrid/v_e,r_e,vrat_e,dr_e,dv_e +!*********************************************************************** +! constantes communes a la microphysique. +!*********************************************************************** + real pi, & + & nav,rgp,kbz, & + & rtit,g0, & + & mch4,mc2h6,mc2h2,mar,mn2,mair, & + & rhol,rhoi_ch4,rhoi_c2h6,rhoi_c2h2, & + & mtetach4,mtetac2h6,mtetac2h2 + + common/phys/ & + & pi, & + & nav,rgp,kbz, & + & rtit,g0, & + & mch4,mc2h6,mc2h2,mar,mn2,mair, & + & rhol,rhoi_ch4,rhoi_c2h6,rhoi_c2h2, & + & mtetach4,mtetac2h6,mtetac2h2 + Index: trunk/LMDZ.TITAN.old/libf/phytitan/vdif_kcay.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/vdif_kcay.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/vdif_kcay.F (revision 1643) @@ -0,0 +1,739 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/vdif_kcay.F,v 1.1 2004/06/22 11:45:36 lmdzadmin Exp $ +! + SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar + s ,l_mix) +c....................................................................... + use dimphy + IMPLICIT NONE +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),q2s(klon,klev+1) + REAL q2diag(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon) + + integer l_mix,iii +c....................................................................... +c +c nlay : nombre de couches +c nlev : nombre de niveaux +c ngrid : nombre de points de grille +c unsdz : 1 sur l'epaisseur de couche +c unsdzdec : 1 sur la distance entre le centre de la couche et le +c centre de la couche inferieure +c q : echelle de vitesse au bas de chaque couche +c (valeur a la fin du pas de temps) +c +c....................................................................... + INTEGER nlay,nlev,ngrid + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + REAL q(klon,klev+1) + +c....................................................................... +c +c kmpre : km au debut du pas de temps +c qcstat : q : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c q2cstat : q2 : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c +c....................................................................... + REAL kmpre(klon,klev+1) + REAL qcstat + REAL q2cstat + real sss,sssq +c....................................................................... +c +c long : longueur de melange calculee selon Blackadar +c +c....................................................................... + REAL long(klon,klev+1) +c....................................................................... +c +c kmq3 : terme en q^3 dans le developpement de km +c (valeur au debut du pas de temps) +c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c knq3 : terme en q^3 dans le developpement de kn +c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m : valeur a la fin du pas de temps +c mpre : valeur au debut du pas de temps +c m2 : valeur a la fin du pas de temps +c n2 : valeur a la fin du pas de temps +c +c....................................................................... + REAL kmq3 + REAL kmcstat + REAL knq3 + REAL mcstat + REAL m2cstat + REAL m(klon,klev+1) + REAL mpre(klon,klev+1) + REAL m2(klon,klev+1) + REAL n2(klon,klev+1) +c....................................................................... +c +c gn : intermediaire pour les coefficients de stabilite +c gnmin : borne inferieure de gn (-0.23 ou -0.28) +c gnmax : borne superieure de gn (0.0233) +c gninf : vrai si gn est en dessous de sa borne inferieure +c gnsup : vrai si gn est en dessus de sa borne superieure +c gm : drole d'objet bien utile +c ri : nombre de Richardson +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c sm : coefficient de stabilite pour m +c smq2 : premier terme du developement limite de sm en q2 +c +c....................................................................... + REAL gn + REAL gnmin + REAL gnmax + LOGICAL gninf + LOGICAL gnsup + REAL gm +c REAL ri(klon,klev+1) + REAL sn(klon,klev+1) + REAL snq2(klon,klev+1) + REAL sm(klon,klev+1) + REAL smq2(klon,klev+1) +c....................................................................... +c +c kappa : consatnte de Von Karman (0.4) +c long00 : longueur de reference pour le calcul de long (160) +c a1,a2,b1,b2,c1 : constantes d'origine pour les coefficients +c de stabilite (0.92/0.74/16.6/10.1/0.08) +c cn1,cn2 : constantes pour sn +c cm1,cm2,cm3,cm4 : constantes pour sm +c +c....................................................................... + REAL kappa + REAL long00 + REAL a1,a2,b1,b2,c1 + REAL cn1,cn2 + REAL cm1,cm2,cm3,cm4 +c....................................................................... +c +c termq : termes en $q$ dans l'equation de q2 +c termq3 : termes en $q^3$ dans l'equation de q2 +c termqm2 : termes en $q*m^2$ dans l'equation de q2 +c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2 +c +c....................................................................... + REAL termq + REAL termq3 + REAL termqm2 + REAL termq3m2 +c....................................................................... +c +c q2min : borne inferieure de q2 +c q2max : borne superieure de q2 +c +c....................................................................... + REAL q2min + REAL q2max +c....................................................................... +c knmin : borne inferieure de kn +c kmmin : borne inferieure de km +c....................................................................... + REAL knmin + REAL kmmin +c....................................................................... + INTEGER ilay,ilev,igrid + REAL tmp1,tmp2 +c....................................................................... + PARAMETER (kappa=0.4E+0) + PARAMETER (long00=160.E+0) +c PARAMETER (gnmin=-10.E+0) + PARAMETER (gnmin=-0.28) + PARAMETER (gnmax=0.0233E+0) + PARAMETER (a1=0.92E+0) + PARAMETER (a2=0.74E+0) + PARAMETER (b1=16.6E+0) + PARAMETER (b2=10.1E+0) + PARAMETER (c1=0.08E+0) + PARAMETER (knmin=1.E-5) + PARAMETER (kmmin=1.E-5) + PARAMETER (q2min=1.e-5) + PARAMETER (q2max=1.E+2) +c + PARAMETER ( + & cn1=a2*(1.E+0 -6.E+0 *a1/b1) + & ) + PARAMETER ( + & cn2=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1) + & ) + PARAMETER ( + & cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1) + & -3.E+0 *c1*(b2+6.E+0 *a1))) + & ) + PARAMETER ( + & cm3=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm4=-9.E+0 *a1*a2 + & ) + + logical first + save first + data first/.true./ + + nlay=klev + nlev=klev+1 +c....................................................................... +c traitment des valeur de q2 en entree +c....................................................................... +c +c Initialisation de q2 + + call yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar + s ,l_mix) + if (first.and.1.eq.1) then + first=.false. + q2=q2diag + endif + + DO ilev=1,nlev + DO igrid=1,ngrid + q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + ENDDO + ENDDO +c + DO igrid=1,ngrid + tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2) + q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1 + q2(igrid,1)=amax1(q2(igrid,1),q2min) + q(igrid,1)=sqrt(q2(igrid,1)) + ENDDO +c +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO igrid=1,ngrid + zlev(igrid,nlev)=zlay(igrid,nlay) + & +( zlay(igrid,nlay) - zlev(igrid,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO ilay=1,nlay + DO igrid=1,ngrid + unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1)) + ENDDO + DO ilay=2,nlay + DO igrid=1,ngrid + unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay)) + ENDDO +c +c....................................................................... +c le cisaillement et le gradient de temperature +c....................................................................... +c + DO igrid=1,ngrid + m2(igrid,1)=(unsdzdec(igrid,1) + & *u(igrid,1))**2 + & +(unsdzdec(igrid,1) + & *v(igrid,1))**2 + m(igrid,1)=sqrt(m2(igrid,1)) + mpre(igrid,1)=m(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + n2(igrid,ilev)=g*unsdzdec(igrid,ilev) + & *(teta(igrid,ilev)-teta(igrid,ilev-1)) + & /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0 +c n2(igrid,ilev)=0. +c +c ---> +c on ne sais traiter que les cas stratifies. et l'ajustement +c convectif est cense faire en sorte que seul des configurations +c stratifiees soient rencontrees en entree de cette routine. +c mais, bon ... on sait jamais (meme on sait que n2 prends +c quelques valeurs negatives ... parfois) alors : +c<--- +c + IF (n2(igrid,ilev).lt.0.E+0) THEN + n2(igrid,ilev)=0.E+0 + ENDIF +c + m2(igrid,ilev)=(unsdzdec(igrid,ilev) + & *(u(igrid,ilev)-u(igrid,ilev-1)))**2 + & +(unsdzdec(igrid,ilev) + & *(v(igrid,ilev)-v(igrid,ilev-1)))**2 + m(igrid,ilev)=sqrt(m2(igrid,ilev)) + mpre(igrid,ilev)=m(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + m2(igrid,nlev)=m2(igrid,nlev-1) + m(igrid,nlev)=m(igrid,nlev-1) + mpre(igrid,nlev)=m(igrid,nlev) + ENDDO +c +c....................................................................... +c calcul des fonctions de stabilite +c....................................................................... +c + if (l_mix.eq.4) then + DO igrid=1,ngrid + sqz(igrid)=1.e-10 + sq(igrid)=1.e-10 + ENDDO + do ilev=2,nlev-1 + DO igrid=1,ngrid + zq=sqrt(q2(igrid,ilev)) + sqz(igrid) + . =sqz(igrid)+zq*zlev(igrid,ilev) + . *(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + ENDDO + enddo + DO igrid=1,ngrid + long0(igrid)=0.2*sqz(igrid)/sq(igrid) + ENDDO + else if (l_mix.eq.3) then + long0(igrid)=long00 + endif + +c (abd 5 2) print*,'LONG0=',long0 + +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1)) + if (l_mix.ge.10) then + long(igrid,ilev)=l_mix + else + long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid)) + endif + long(igrid,ilev)=max(min(long(igrid,ilev) + s ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10))) + s ,5.) + + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + gm=long(igrid,ilev)**2 / q2(igrid,ilev) + & * m2(igrid,ilev) +c + gninf=.false. + gnsup=.false. + long(igrid,ilev)=long(igrid,ilev) + long(igrid,ilev)=long(igrid,ilev) +c + IF (gn.lt.gnmin) THEN + gninf=.true. + gn=gnmin + ENDIF +c + IF (gn.gt.gnmax) THEN + gnsup=.true. + gn=gnmax + ENDIF +c + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) ) +c + IF ((gninf).or.(gnsup)) THEN + snq2(igrid,ilev)=0.E+0 + smq2(igrid,ilev)=0.E+0 + ELSE + snq2(igrid,ilev)= + & -gn + & *(-cn1*cn2/(1.E+0 +cn2*gn)**2 ) + smq2(igrid,ilev)= + & -gn + & *( cm2*(1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) + & -( cm3*(1.E+0 +cm4*gn) + & +cm4*(1.E+0 +cm3*gn) ) + & *(cm1+cm2*gn) ) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) )**2 + ENDIF +c +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c ---> +c la decomposition de Taylor en q2 n'a de sens que +c dans les cas stratifies ou sn et sm sont quasi +c proportionnels a q2. ailleurs on laisse le meme +c algorithme car l'ajustement convectif fait le travail. +c mais c'est delirant quand sn et snq2 n'ont pas le meme +c signe : dans ces cas, on ne fait pas la decomposition. +c<--- +c + IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0) + & snq2(igrid,ilev)=0.E+0 + IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0) + & smq2(igrid,ilev)=0.E+0 +c +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c +c....................................................................... +c calcul de km et kn au debut du pas de temps +c....................................................................... +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin + kmpre(igrid,1)=km(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) + kmpre(igrid,ilev)=km(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + kmpre(igrid,nlev)=km(igrid,nlev) + ENDDO +c +c....................................................................... +c boucle sur les niveaux 2 a nlev-1 +c....................................................................... +c +c----> + DO 10001 ilev=2,nlev-1 +c----> + DO 10002 igrid=1,ngrid +c +c....................................................................... +c +c calcul des termes sources et puits de l'equation de q2 +c ------------------------------------------------------ +c + knq3=kn(igrid,ilev)*snq2(igrid,ilev) + & /sn(igrid,ilev) + kmq3=km(igrid,ilev)*smq2(igrid,ilev) + & /sm(igrid,ilev) +c + termq=0.E+0 + termq3=0.E+0 + termqm2=0.E+0 + termq3m2=0.E+0 +c + tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev) + termqm2=termqm2 + & +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + & -dt*2.E+0 *kmq3*m2(igrid,ilev) + termq3m2=termq3m2 + & +dt*2.E+0 *kmq3*m2(igrid,ilev) +c + termq=termq + & -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev) + & +dt*2.E+0 *knq3*n2(igrid,ilev) + termq3=termq3 + & -dt*2.E+0 *knq3*n2(igrid,ilev) +c + termq3=termq3 + & -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev)) +c +c....................................................................... +c +c resolution stationnaire couplee avec le gradient de vitesse local +c ----------------------------------------------------------------- +c +c -----{on cherche le cisaillement qui annule l'equation de q^2 +c supposee en q3} +c + tmp1=termq+termq3 + tmp2=termqm2+termq3m2 + m2cstat=m2(igrid,ilev) + & -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev)) + mcstat=sqrt(m2cstat) + +c abde print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (ilev.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1) + & *cd(igrid) + & *( sqrt(u(igrid,3)**2+v(igrid,3)**2) + & -mcstat/unsdzdec(igrid,ilev) + & -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1) + & *mpre(igrid,ilev-1) ) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ENDIF + tmp2=kmcstat + & /( sm(igrid,ilev)/q2(igrid,ilev) ) + & /long(igrid,ilev) + qcstat=tmp2**(1.E+0/3.E+0) + q2cstat=qcstat**2 +c +c....................................................................... +c +c choix de la solution finale +c --------------------------- +c + q(igrid,ilev)=qcstat + q2(igrid,ilev)=q2cstat + m(igrid,ilev)=mcstat +c abd if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' M2=',m2(igrid,ilev),m2cstat, +c s 'N2=',n2(igrid,ilev) +c abd endif + m2(igrid,ilev)=m2cstat +c +c ---> +c pour des raisons simples q2 est minore +c<--- +c + IF (q2(igrid,ilev).lt.q2min) THEN + q2(igrid,ilev)=q2min + q(igrid,ilev)=sqrt(q2min) + ENDIF +c +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c +c....................................................................... +c +10002 CONTINUE +c +10001 CONTINUE +c +c....................................................................... +c +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin +c kn(igrid,1)=cd(igrid) +c km(igrid,1)=cd(igrid) + q2(igrid,nlev)=q2(igrid,nlev-1) + q(igrid,nlev)=q(igrid,nlev-1) + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + ENDDO +c +c CALCUL DE LA DIFFUSION VERTICALE DE Q2 + if (1.eq.1) then + + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo +c print*,'Q2moy avant',sssq/sss +c print*,'Q2q20 ',(q2(1,ilev),ilev=1,10) +c print*,'Q2km0 ',(km(1,ilev),ilev=1,10) +c ! C'est quoi ca qu'etait dans l'original??? +c do igrid=1,ngrid +c q2(igrid,1)=10. +c enddo +c q2s=q2 +c do iii=1,10 +c call vdif_q2(dt,g,rconst,plev,temp,km,q2) +c do ilev=1,klev+1 +c write(iii+49,*) q2(1,ilev),zlev(1,ilev) +c enddo +c enddo +c stop +c do ilev=1,klev +c print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev) +c enddo +c q2s=q2-q2s +c do ilev=1,klev +c print*,q2s(1,ilev),zlev(1,ilev) +c enddo + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo + print*,'Q2moy apres',sssq/sss +c +c + do ilev=1,nlev + do igrid=1,ngrid + q2(igrid,ilev)=max(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) +c + enddo + enddo +c print*,'Q2km1 ',(km(1,ilev),ilev=1,10) + + endif + + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/write_histday.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/write_histday.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/write_histday.h (revision 1643) @@ -0,0 +1,359 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/write_histday.h,v 1.2 2004/06/01 09:27:10 lmdzadmin Exp $ +! + IF (ok_journe) THEN + + zsto = dtime + zout = dtime * REAL(ecrit_day) + itau_w = itau_phy + itap + +c------------------------------------------------------- + IF(lev_histday.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + call histwrite_phy(nid_day,.false.,"phis",itau_w,pphis) +c call histwrite_phy(nid_day,.false.,"aire",itau_w,cell_area) + cell_area_out(:)=cell_area(:) + if (is_north_pole_phy) cell_area_out(1)=cell_area(1)/nbp_lon + if (is_south_pole_phy) cell_area_out(klon)=cell_area(klon)/nbp_lon + call histwrite_phy(nid_day,.false.,"aire",itau_w,cell_area_out) + +ccccccc axe Ls ... Faudrait le reduire a axe temporel seulement... +c Correction passage de 360 a 0... Sinon probleme avec moyenne + if (zls.lt.zlsm1) then + do i=1,klon + tmpout(i,1) = zls*180./RPI+360. + enddo + zlsm1 = 2.*RPI + else + do i=1,klon + tmpout(i,1) = zls*180./RPI + enddo + zlsm1 = zls + endif + call histwrite_phy(nid_day,.false.,"ls",itau_w,tmpout(:,1)) + +ccccccccccccc 2D fields, variables + + call histwrite_phy(nid_day,.false.,"tsol",itau_w,ftsol) + call histwrite_phy(nid_day,.false.,"psol",itau_w,paprs(:,1)) + +c call histwrite_phy(nid_day,.false.,"ue",itau_w,ue) +c call histwrite_phy(nid_day,.false.,"ve",itau_w,ve) + + ENDIF !lev_histday.GE.1 + +c------------------------------------------------------- + IF(lev_histday.GE.2) THEN + +ccccccccccccc 3D fields, basics + + call histwrite_phy(nid_day,.false.,"temp",itau_w,t_seri) + call histwrite_phy(nid_day,.false.,"pres",itau_w,pplay) + call histwrite_phy(nid_day,.false.,"geop",itau_w,zphi) + call histwrite_phy(nid_day,.false.,"vitu",itau_w,u_seri) + call histwrite_phy(nid_day,.false.,"vitv",itau_w,v_seri) + call histwrite_phy(nid_day,.false.,"vitw",itau_w,omega) + call histwrite_phy(nid_day,.false.,"tops",itau_w,topsw) + call histwrite_phy(nid_day,.false.,"duvdf",itau_w,d_u_vdf) + call histwrite_phy(nid_day,.false.,"dudyn",itau_w,d_u_dyn) + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.ge.1) then +c DO iq=1,nmicro +c call histwrite_phy(nid_day,.false.,tname(iq), +c . itau_w,qaer(1:klon,1:klev,iq)) +c ENDDO +c ------- NB AER TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,1:nrad)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"qaer",itau_w,tmpout) + + if (clouds.eq.1) then +c ------- NB NOY TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,nrad+1:2*nrad)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"qnoy",itau_w,tmpout) +c ------- V GLA1 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,2*nrad+1:3*nrad)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"qgl1",itau_w,tmpout) +c ------- V GLA2 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,3*nrad+1:4*nrad)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"qgl2",itau_w,tmpout) +c ------- V GLA3 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,4*nrad+1:5*nrad)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"qgl3",itau_w,tmpout) +c -------------- +c ----- SATURATION ESP NUAGES + call histwrite_phy(nid_day,.false.,"ch4sat",itau_w,satch4) + call histwrite_phy(nid_day,.false.,"c2h6sat",itau_w,satc2h6) + call histwrite_phy(nid_day,.false.,"c2h2sat",itau_w,satc2h2) +c -------------- +c ----- RESERVOIR DE SURFACE + call histwrite_phy(nid_day,.false.,"reserv",itau_w,reservoir) +c -------------- +c ----- ECHANGE GAZ SURF/ATM (evaporation) + call histwrite_phy(nid_day,.false.,"evapch4",itau_w,evapch4) +c -------------- +c ----- PRECIPITATIONS +c ----- CH4 + call histwrite_phy(nid_day,.false.,"prech4", + . itau_w,precip(1:klon,1)) +c ----- C2H6 + call histwrite_phy(nid_day,.false.,"prec2h6", + . itau_w,precip(1:klon,2)) +c ----- C2H2 + call histwrite_phy(nid_day,.false.,"prec2h2", + . itau_w,precip(1:klon,3)) +c ----- NOY + call histwrite_phy(nid_day,.false.,"prenoy", + . itau_w,precip(1:klon,4)) +c ----- AER + call histwrite_phy(nid_day,.false.,"preaer", + . itau_w,precip(1:klon,5)) +c -------------- +c ----- FLUX GLACE +c ----- CH4 + call histwrite_phy(nid_day,.false.,"flxgl1", + . itau_w,flxesp_i(1:klon,1:klev,1)) +c ----- C2H6 + call histwrite_phy(nid_day,.false.,"flxgl2", + . itau_w,flxesp_i(1:klon,1:klev,2)) +c ----- C2H2 + call histwrite_phy(nid_day,.false.,"flxgl3", + . itau_w,flxesp_i(1:klon,1:klev,3)) +c -------------- +c ----- Source/puits GLACE +c ----- CH4 + call histwrite_phy(nid_day,.false.,"solch4", + . itau_w,solesp(1:klon,1:klev,1)) +c ----- C2H6 + call histwrite_phy(nid_day,.false.,"solc2h6", + . itau_w,solesp(1:klon,1:klev,2)) +c ----- C2H2 + call histwrite_phy(nid_day,.false.,"solc2h2", + . itau_w,solesp(1:klon,1:klev,3)) +c -------------- +c ----- RAYON MOYEN GOUTTE + call histwrite_phy(nid_day,.false.,"rcldbar",itau_w,rmcloud) + + endif + endif + +c -------------- +c ----- TRACEURS CHIMIQUES + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + call histwrite_phy(nid_day,.false.,tname(iq), + . itau_w,tr_seri(1:klon,1:klev,iq)) + ENDDO + endif + endif + + ENDIF !lev_histday.GE.2 + +c------------------------------------------------------- + IF(lev_histday.GE.3) THEN + +cccccccccccccccccc Radiative transfer + +c 2D + + call histwrite_phy(nid_day,.false.,"topl",itau_w,toplw) + call histwrite_phy(nid_day,.false.,"sols",itau_w,solsw) + call histwrite_phy(nid_day,.false.,"soll",itau_w,sollw) + +c 3D + + call histwrite_phy(nid_day,.false.,"SWnet", + . itau_w,swnet(1:klon,1:klev)) + call histwrite_phy(nid_day,.false.,"LWnet", + . itau_w,lwnet(1:klon,1:klev)) + +c -------------- +c ----- OPACITE BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"thv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"thi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + s -TAUHVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"khv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + s -TAUHID(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"khi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- OPACITE GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"tgv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"tgi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + s -TAUGVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"kgv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + s -TAUGID(i,klev-l+1-1,k) + + if(l.eq.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_day,.false.,"kgi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI + +c -------------- + if (clouds.eq.1) then +c -------------- +c ----- OPACITE NUAGES (ATTENTION PROXY) + call histwrite_phy(nid_day,.false.,"tcld",itau_w,occcld) +c -------------- +c ----- EXTINCTION NUAGES (ATTENTION PROXY) + do i=1,klon + t_kcld(i,klev)=occcld(i,klev) + . /(zzlev(i,klev+1)-zzlev(i,klev)) + do j=klev-1,1,-1 + t_kcld(i,j)=(occcld(i,j)-occcld(i,j+1)) + . /(zzlev(i,j+1)-zzlev(i,j)) + enddo + enddo + call histwrite_phy(nid_day,.false.,"kcld",itau_w,t_kcld) +c -------------- + endif +c -------------- + + ENDIF !lev_histday.GE.3 + +c------------------------------------------------------- + IF(lev_histday.GE.4) THEN + + call histwrite_phy(nid_day,.false.,"dtdyn",itau_w,d_t_dyn) + call histwrite_phy(nid_day,.false.,"dtphy",itau_w,d_t) +c K/s + call histwrite_phy(nid_day,.false.,"dtvdf",itau_w,d_t_vdf) +c K/s + call histwrite_phy(nid_day,.false.,"dtajs",itau_w,d_t_ajs) +c K/s + call histwrite_phy(nid_day,.false.,"dtswr",itau_w,heat) +c K/s + call histwrite_phy(nid_day,.false.,"dtlwr",itau_w,-1.*cool) +c K/s +c call histwrite_phy(nid_day,.false.,"dtec",itau_w,d_t_ec) + + ENDIF !lev_histday.GE.4 + +c------------------------------------------------------- + IF(lev_histday.GE.5) THEN + +c call histwrite_phy(nid_day,.false.,"taux",itau_w,fluxu) +c call histwrite_phy(nid_day,.false.,"tauy",itau_w,fluxv) +c call histwrite_phy(nid_day,.false.,"cdrm",itau_w,cdragm) +c call histwrite_phy(nid_day,.false.,"cdrh",itau_w,cdragh) + + ENDIF !lev_histday.GE.5 +c------------------------------------------------------- + + if (ok_sync) then + call histsync(nid_day) + endif + + ENDIF Index: trunk/LMDZ.TITAN.old/libf/phytitan/write_histins.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/write_histins.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/write_histins.h (revision 1643) @@ -0,0 +1,235 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/write_histins.h,v 1.1.1.1 2004/05/19 12:53:09 lmdzadmin Exp $ +! + IF (ok_instan) THEN + + zsto = dtime * REAL(ecrit_ins) + zout = dtime * REAL(ecrit_ins) + itau_w = itau_phy + itap + +c------------------------------------------------------- + IF(lev_histday.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + call histwrite_phy(nid_ins,.false.,"phis",itau_w,pphis) +c call histwrite_phy(nid_ins,.false.,"aire",itau_w,cell_area) + cell_area_out(:)=cell_area(:) + if (is_north_pole_phy) cell_area_out(1)=cell_area(1)/nbp_lon + if (is_south_pole_phy) cell_area_out(klon)=cell_area(klon)/nbp_lon + call histwrite_phy(nid_ins,.false.,"aire",itau_w,cell_area_out) + +ccccccc axe Ls ... Faudrait le reduire a axe temporel seulement... + do i=1,klon + tmpout(i,1) = zls*180./RPI + enddo + call histwrite_phy(nid_ins,.false.,"ls",itau_w,tmpout(:,1)) + +ccccccccccccc 2D fields, variables + + call histwrite_phy(nid_ins,.false.,"tsol",itau_w,ftsol) + call histwrite_phy(nid_ins,.false.,"psol",itau_w,paprs(:,1)) + +c call histwrite_phy(nid_ins,.false.,"ue",itau_w,ue) +c call histwrite_phy(nid_ins,.false.,"ve",itau_w,ve) + + ENDIF !lev_histday.GE.1 + +c------------------------------------------------------- + IF(lev_histday.GE.2) THEN + +ccccccccccccc 3D fields, basics + + call histwrite_phy(nid_ins,.false.,"temp",itau_w,t_seri) + call histwrite_phy(nid_ins,.false.,"pres",itau_w,pplay) + call histwrite_phy(nid_ins,.false.,"geop",itau_w,zphi) + call histwrite_phy(nid_ins,.false.,"vitu",itau_w,u_seri) + call histwrite_phy(nid_ins,.false.,"vitv",itau_w,v_seri) + call histwrite_phy(nid_ins,.false.,"vitw",itau_w,omega) + call histwrite_phy(nid_ins,.false.,"tops",itau_w,topsw) +c call histwrite_phy(nid_ins,.false.,"duvdf",itau_w,d_u_vdf) +c call histwrite_phy(nid_ins,.false.,"dudyn",itau_w,d_u_dyn) + + ENDIF !lev_histday.GE.2 + +c------------------------------------------------------- + IF(lev_histday.GE.3) THEN + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.eq.1) then + DO iq=1,nmicro + call histwrite_phy(nid_ins,.false.,tname(iq), + . itau_w,qaer(1:klon,1:klev,iq)) + ENDDO + endif + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + call histwrite_phy(nid_ins,.false.,tname(iq), + . itau_w,tr_seri(1:klon,1:klev,iq)) + ENDDO + endif + endif + +cccccccccccccccccc Radiative transfer + +c 2D + + call histwrite_phy(nid_ins,.false.,"topl",itau_w,toplw) + call histwrite_phy(nid_ins,.false.,"sols",itau_w,solsw) + call histwrite_phy(nid_ins,.false.,"soll",itau_w,sollw) + +c 3D + + call histwrite_phy(nid_ins,.false.,"SWnet", + . itau_w,swnet(1:klon,1:klev)) + call histwrite_phy(nid_ins,.false.,"LWnet", + . itau_w,lwnet(1:klon,1:klev)) + +c -------------- +c ----- OPACITE BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"thv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"thi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + s -TAUHVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"khv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + s -TAUHID(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"khi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- OPACITE GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"tgv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"tgi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + s -TAUGVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"kgv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + s -TAUGID(i,klev-l+1-1,k) + + if(l.eq.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_ins,.false.,"kgi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI + + ENDIF !lev_histday.GE.3 + +c------------------------------------------------------- + IF(lev_histday.GE.4) THEN + + call histwrite_phy(nid_ins,.false.,"dtdyn",itau_w,d_t_dyn) + call histwrite_phy(nid_ins,.false.,"dtphy",itau_w,d_t) +c K/s + call histwrite_phy(nid_ins,.false.,"dtvdf",itau_w,d_t_vdf) +c K/s + call histwrite_phy(nid_ins,.false.,"dtajs",itau_w,d_t_ajs) +c K/s + call histwrite_phy(nid_ins,.false.,"dtswr",itau_w,heat) +c K/s + call histwrite_phy(nid_ins,.false.,"dtlwr",itau_w,-1.*cool) +c K/s +c call histwrite_phy(nid_ins,.false.,"dtec",itau_w,d_t_ec) +c call histwrite_phy(nid_ins,.false.,"dvvdf",itau_w,d_v_vdf) + + ENDIF !lev_histday.GE.4 + +c------------------------------------------------------- + IF(lev_histday.GE.5) THEN + +c call histwrite_phy(nid_ins,.false.,"taux",itau_w,fluxu) +c call histwrite_phy(nid_ins,.false.,"tauy",itau_w,fluxv) +c call histwrite_phy(nid_ins,.false.,"cdrm",itau_w,cdragm) +c call histwrite_phy(nid_ins,.false.,"cdrh",itau_w,cdragh) + + ENDIF !lev_histday.GE.5 +c------------------------------------------------------- + + if (ok_sync) then + call histsync(nid_ins) + endif + ENDIF Index: trunk/LMDZ.TITAN.old/libf/phytitan/write_histmth.h =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/write_histmth.h (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/write_histmth.h (revision 1643) @@ -0,0 +1,382 @@ + IF (ok_mensuel) THEN + + zsto = dtime + zout = dtime * REAL(ecrit_mth) + itau_w = itau_phy + itap + +c------------------------------------------------------- + IF(lev_histmth.GE.1) THEN + +ccccccccccccc 2D fields, invariables + + call histwrite_phy(nid_mth,.false.,"phis",itau_w,pphis) +c call histwrite_phy(nid_mth,.false.,"aire",itau_w,cell_area) + cell_area_out(:)=cell_area(:) + if (is_north_pole_phy) cell_area_out(1)=cell_area(1)/nbp_lon + if (is_south_pole_phy) cell_area_out(klon)=cell_area(klon)/nbp_lon + call histwrite_phy(nid_mth,.false.,"aire",itau_w,cell_area_out) + +ccccccc axe Ls ... Faudrait le reduire a axe temporel seulement... +c Correction passage de 360 a 0... Sinon probleme avec moyenne + if (zls.lt.zlsm1) then + do i=1,klon + tmpout(i,1) = zls*180./RPI+360. + enddo + zlsm1 = 2.*RPI + else + do i=1,klon + tmpout(i,1) = zls*180./RPI + enddo + zlsm1 = zls + endif + call histwrite_phy(nid_mth,.false.,"ls",itau_w,tmpout(:,1)) + +ccccccccccccc 2D fields, variables + + call histwrite_phy(nid_mth,.false.,"tsol",itau_w,ftsol) + call histwrite_phy(nid_mth,.false.,"psol",itau_w,paprs(:,1)) + +c call histwrite_phy(nid_mth,.false.,"ue",itau_w,ue) +c call histwrite_phy(nid_mth,.false.,"ve",itau_w,ve) + + ENDIF !lev_histmth.GE.1 + +c------------------------------------------------------- + IF(lev_histmth.GE.2) THEN + +ccccccccccccc 3D fields, basics + + call histwrite_phy(nid_mth,.false.,"temp",itau_w,t_seri) + call histwrite_phy(nid_mth,.false.,"pres",itau_w,pplay) + call histwrite_phy(nid_mth,.false.,"geop",itau_w,zphi) + call histwrite_phy(nid_mth,.false.,"vitu",itau_w,u_seri) + call histwrite_phy(nid_mth,.false.,"vitv",itau_w,v_seri) + call histwrite_phy(nid_mth,.false.,"vitw",itau_w,omega) +c call histwrite_phy(nid_mth,.false.,"Kz",itau_w,ycoefh) + call histwrite_phy(nid_mth,.false.,"tops",itau_w,topsw) + call histwrite_phy(nid_mth,.false.,"duvdf",itau_w,d_u_vdf) + call histwrite_phy(nid_mth,.false.,"dudyn",itau_w,d_u_dyn) + +cccccccccccccccccc Tracers + + if (iflag_trac.eq.1) THEN + if (microfi.ge.1) then +c DO iq=1,nmicro +c call histwrite_phy(nid_mth,.false.,tname(iq), +c . itau_w,qaer(1:klon,1:klev,iq)) +c ENDDO +c ------- NB AER TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,1:nrad)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"qaer",itau_w,tmpout) + + if (clouds.eq.1) then +c ------- NB NOY TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,nrad+1:2*nrad)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"qnoy",itau_w,tmpout) +c ------- V GLA1 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,2*nrad+1:3*nrad)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"qgl1",itau_w,tmpout) +c ------- V GLA2 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,3*nrad+1:4*nrad)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"qgl2",itau_w,tmpout) +c ------- V GLA3 TOT + do i=1,klon + do j=1,klev + tmpout(i,j)= SUM(qaer(i,j,4*nrad+1:5*nrad)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"qgl3",itau_w,tmpout) +c -------------- +c ----- SATURATION ESP NUAGES + call histwrite_phy(nid_mth,.false.,"ch4sat",itau_w,satch4) + call histwrite_phy(nid_mth,.false.,"c2h6sat",itau_w,satc2h6) + call histwrite_phy(nid_mth,.false.,"c2h2sat",itau_w,satc2h2) +c -------------- +c ----- RESERVOIR DE SURFACE + call histwrite_phy(nid_mth,.false.,"reserv",itau_w,reservoir) +c -------------- +c ----- ECHANGE GAZ SURF/ATM (evaporation) + call histwrite_phy(nid_mth,.false.,"evapch4",itau_w,evapch4) +c -------------- +c ----- PRECIPITATIONS +c ----- CH4 + call histwrite_phy(nid_mth,.false.,"prech4", + . itau_w,precip(1:klon,1)) +c ----- C2H6 + call histwrite_phy(nid_mth,.false.,"prec2h6", + . itau_w,precip(1:klon,2)) +c ----- C2H2 + call histwrite_phy(nid_mth,.false.,"prec2h2", + . itau_w,precip(1:klon,3)) +c ----- NOY + call histwrite_phy(nid_mth,.false.,"prenoy", + . itau_w,precip(1:klon,4)) +c ----- AER + call histwrite_phy(nid_mth,.false.,"preaer", + . itau_w,precip(1:klon,5)) +c -------------- +c ----- FLUX GLACE +c ----- CH4 + call histwrite_phy(nid_mth,.false.,"flxgl1", + . itau_w,flxesp_i(1:klon,1:klev,1)) +c ----- C2H6 + call histwrite_phy(nid_mth,.false.,"flxgl2", + . itau_w,flxesp_i(1:klon,1:klev,2)) +c ----- C2H2 + call histwrite_phy(nid_mth,.false.,"flxgl3", + . itau_w,flxesp_i(1:klon,1:klev,3)) +c -------------- +c ----- Source/puits GLACE +c ----- CH4 + call histwrite_phy(nid_mth,.false.,"solch4", + . itau_w,solesp(1:klon,1:klev,1)) +c ----- C2H6 + call histwrite_phy(nid_mth,.false.,"solc2h6", + . itau_w,solesp(1:klon,1:klev,2)) +c ----- C2H2 + call histwrite_phy(nid_mth,.false.,"solc2h2", + . itau_w,solesp(1:klon,1:klev,3)) +c -------------- +c ----- RAYON MOYEN GOUTTE + call histwrite_phy(nid_mth,.false.,"rcldbar",itau_w,rmcloud) + + endif + endif + +c -------------- +c ----- TRACEURS CHIMIQUES + if (nmicro.lt.nqmax) then + DO iq=nmicro+1,nqmax + call histwrite_phy(nid_mth,.false.,tname(iq), + . itau_w,tr_seri(1:klon,1:klev,iq)) + ENDDO +c Condensation: +c DO iq=nmicro+1,nqmax +c call histwrite_phy(nid_mth,.false.,"c_"//tname(iq), +c . itau_w,d_tr_mph(1:klon,1:klev,iq)) +c ENDDO + endif + endif + + ENDIF !lev_histmth.GE.2 + +c------------------------------------------------------- + IF(lev_histmth.GE.3) THEN + +cccccccccccccccccc Radiative transfer + +c 2D + + call histwrite_phy(nid_mth,.false.,"topl",itau_w,toplw) + call histwrite_phy(nid_mth,.false.,"sols",itau_w,solsw) + call histwrite_phy(nid_mth,.false.,"soll",itau_w,sollw) + +c 3D + + call histwrite_phy(nid_mth,.false.,"SWnet", + . itau_w,swnet(1:klon,1:klev)) +c call histwrite_phy(nid_mth,.false.,"SWup", +c . itau_w,swup(1:klon,1:klev)) +c call histwrite_phy(nid_mth,.false.,"SWdn", +c . itau_w,swdn(1:klon,1:klev)) + call histwrite_phy(nid_mth,.false.,"LWnet", + . itau_w,lwnet(1:klon,1:klev)) +c call histwrite_phy(nid_mth,.false.,"LWup", +c . itau_w,lwup(1:klon,1:klev)) +c call histwrite_phy(nid_mth,.false.,"LWdn", +c . itau_w,lwdn(1:klon,1:klev)) + call histwrite_phy(nid_mth,.false.,"fluxvdf",itau_w,fluxt) + call histwrite_phy(nid_mth,.false.,"fluxdyn",itau_w,flux_dyn) + call histwrite_phy(nid_mth,.false.,"fluxajs",itau_w,flux_ajs) +c call histwrite_phy(nid_mth,.false.,"fluxec",itau_w,flux_ec) + +c -------------- +c ----- OPACITE BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"thv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUHID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"thi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION BRUME + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + s -TAUHVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"khv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + s -TAUHID(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUHID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"khi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- OPACITE GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGVD(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"tgv"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + t_tauhvd(i,l)=TAUGID(i,klev-l+1,k) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"tgi"//str2,itau_w,t_tauhvd) + enddo ! fin boucle NSPECI +c -------------- +c ----- EXTINCTION GAZ + do k=7,NSPECV,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + s -TAUGVD(i,klev-l+1-1,k) + if(l.eq.klev) + s t_khvd(i,l)=TAUGVD(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"kgv"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECV + + do k=8,NSPECI,10 + do i=1,klon + do l=1,klev + if(l.ne.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + s -TAUGID(i,klev-l+1-1,k) + + if(l.eq.klev) + s t_khvd(i,l)=TAUGID(i,klev-l+1,k) + + t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l)) + enddo + enddo + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"kgi"//str2,itau_w,t_khvd) + enddo ! fin boucle NSPECI + +c -------------- + if (clouds.eq.1) then +c -------------- +c ----- OPACITE NUAGES (ATTENTION PROXY) + call histwrite_phy(nid_mth,.false.,"tcld",itau_w,occcld) +c -------------- +c ----- EXTINCTION NUAGES (ATTENTION PROXY) + do i=1,klon + t_kcld(i,klev)=occcld(i,klev) + . /(zzlev(i,klev+1)-zzlev(i,klev)) + do j=klev-1,1,-1 + t_kcld(i,j)=(occcld(i,j)-occcld(i,j+1)) + . /(zzlev(i,j+1)-zzlev(i,j)) + enddo + enddo + call histwrite_phy(nid_mth,.false.,"kcld",itau_w,t_kcld) +c -------------- +c ----- OCCURENCE NUAGES + do k=1,12 + write(str2,'(i2.2)') k + call histwrite_phy(nid_mth,.false.,"occcld"//str2, + . itau_w,occcld_m(1:klon,1:klev,k)) + enddo +c -------------- + endif +c -------------- + + ENDIF !lev_histmth.GE.3 + +c------------------------------------------------------- + IF(lev_histmth.GE.4) THEN + + call histwrite_phy(nid_mth,.false.,"dtdyn",itau_w,d_t_dyn) + call histwrite_phy(nid_mth,.false.,"dtphy",itau_w,d_t) +c K/s + call histwrite_phy(nid_mth,.false.,"dtvdf",itau_w,d_t_vdf) +c K/s + call histwrite_phy(nid_mth,.false.,"dtajs",itau_w,d_t_ajs) +c K/s + call histwrite_phy(nid_mth,.false.,"dtswr",itau_w,heat) +c K/s + call histwrite_phy(nid_mth,.false.,"dtlwr",itau_w,-1.*cool) +c K/s +c call histwrite_phy(nid_mth,.false.,"dtec",itau_w,d_t_ec) +c call histwrite_phy(nid_mth,.false.,"dvvdf",itau_w,d_v_vdf) + + ENDIF !lev_histmth.GE.4 +c +c------------------------------------------------------- + IF(lev_histmth.GE.5) THEN + +c call histwrite_phy(nid_mth,.false.,"taux",itau_w,fluxu) +c call histwrite_phy(nid_mth,.false.,"tauy",itau_w,fluxv) +c call histwrite_phy(nid_mth,.false.,"cdrm",itau_w,cdragm) +c call histwrite_phy(nid_mth,.false.,"cdrh",itau_w,cdragh) + + ENDIF !lev_histmth.GE.5 +c------------------------------------------------------- + + if (ok_sync) then + call histsync(nid_mth) + endif + + ENDIF Index: trunk/LMDZ.TITAN.old/libf/phytitan/xmie.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/xmie.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/xmie.F (revision 1643) @@ -0,0 +1,28 @@ + SUBROUTINE XMIE(RAD,RREAL,XIMG,QEXT,QSCT,QABS,CBAR,WAVEN) +C CHANGED TO WORK WITH THE VAX MIE VERSION + COMPLEX ACAP(7000) +c COMPLEX ACAP(700000) +c COMPLEX ACAP(2000000) + REAL ELTRMX(4,1,2),PIE(3,1),TAU(3,1),CSTHT(1),SI2THT(1) + REAL RO,REALO,XIMGO,QE,QS,CB,RD2,RN,CN,TPILAM +c print*,RAD,RREAL,XIMG,QEXT,QSCT,QABS,CBAR,WAVEN + RO=RAD + REALO=RREAL + XIMGO=XIMG + RD2=0. + RN=1.0 + CN=0. + WAVEL=1.E4/WAVEN + TPILAM=2.0*3.14159/WAVEL + CALL DMIESS (RO, REALO, XIMGO, 0.0, 1, + * QE, QS,CB, + * ELTRMX,PIE,TAU,CSTHT,SI2THT,ACAP,1, +c * 2000000, RD2, RN, CN, TPILAM) + * 7000, RD2, RN, CN, TPILAM) + CBAR=CB/QS + QEXT=QE*3.14159*RAD*RAD*1.E-8 + QSCT=QS*3.14159*RAD*RAD*1.E-8 + QABS=QEXT-QSCT + SIZE=3.14159*RAD*RAD*1.E-8 + RETURN + END Index: trunk/LMDZ.TITAN.old/libf/phytitan/yamada.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/yamada.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/yamada.F (revision 1643) @@ -0,0 +1,162 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/yamada.F,v 1.1 2004/06/22 11:45:36 lmdzadmin Exp $ +! + SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar + s ,l_mix) +c....................................................................... + use dimphy + IMPLICIT NONE +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + integer l_mix,ngrid + + logical first + save first + data first/.true./ + + integer ig,k + + real ri,zrif,zalpha,zsm + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real l(klon,klev+1),l0(klon) + + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/ + + real frif,falpha,fsm + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif + print*,ri,rif,zalpha,zsm + enddo + first=.false. + endif + +c Correction d'un bug sauvage a verifier. +c do k=2,klevp1 + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1)) + s /(teta(ig,k-1)+teta(ig,k)) /dz(ig,k) + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) + enddo + enddo + +c iterration pour determiner la longueur de melange + + do ig=1,ngrid + l0(ig)=100. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) + enddo +c(abd 3 5 2) print*,'ITER=',iter,' L0=',l0 + + enddo + + do k=2,klev + do ig=1,ngrid + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + q2(ig,k)=l(ig,k)**2*zz(ig,k) + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + enddo + enddo + + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/yamada4.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/yamada4.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/yamada4.F (revision 1643) @@ -0,0 +1,484 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/yamada4.F,v 1.1 2004/06/22 11:45:36 lmdzadmin Exp $ +! + SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp +c s ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar + s ,zlev,zlay,u,v,teta,cd,km,kn,kq,ustar + s ,iflag_pbl) +c....................................................................... + use dimphy + IMPLICIT NONE +#include "YOMCST.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c iflag_pbl doit valoir entre 6 et 9 +c l=6, on prend systematiquement une longueur d'equilibre +c iflag_pbl=6 : MY 2.0 +c iflag_pbl=7 : MY 2.0.Fournier +c iflag_pbl=8 : MY 2.5 +c iflag_pbl=9 : un test ? + +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL qpre + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + + REAL km(klon,klev+1) + REAL kmpre(klon,klev+1),tmp2 + REAL mpre(klon,klev+1) + REAL kn(klon,klev+1) + REAL kq(klon,klev+1) + real ff(klon,klev+1),delta(klon,klev+1) + real aa(klon,klev+1),aa0,aa1 + integer iflag_pbl,ngrid + + + integer nlay,nlev + + logical first + integer ipas + save first,ipas + data first,ipas/.true.,0/ + + + integer ig,k + + + real ri,zrif,zalpha,zsm,zsn + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real dtetadz(klon,klev+1) + real m2cstat,mcstat,kmcstat + real l(klon,klev+1) + real,save,allocatable :: l0(:) +c ATTENTION! mis ici car j'ai enlevé q2 des arguments... +c sinon, c'est au-dessus que ça se passe... + REAL,save,allocatable :: q2(:,:) + + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/ + + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + +c real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) +c s ,lyam(klon,klev),knyam(klon,klev) +c s ,w2yam(klon,klev),t2yam(klon,klev) + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + fl(zzz,zl0,zq2,zn2)= + s max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) + + if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then + stop'probleme de coherence dans appel a MY' + endif + +c=================================== +c INITIALISATIONS + nlay=klev + nlev=klev+1 + + if (first) then + allocate(l0(klon)) + allocate(q2(klon,klevp1)) + +c (surtout pour k=1, à cause diagnostiques...) + q2 = 0. + endif +c=================================== + + ipas=ipas+1 + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif +c print*,ri,rif,zalpha,zsm + enddo + endif + +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO ig=1,ngrid + zlev(ig,nlev)=zlay(ig,nlay) + & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO k=1,nlay + DO ig=1,ngrid + unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) + ENDDO + DO k=2,nlay + DO ig=1,ngrid + unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + ENDDO +c +c....................................................................... + +c=================================== +c INITIALISATIONS (surtout pour k=1, à cause diagnostiques...) + dz = 0. + m2 = 0. + dtetadz = 0. + n2 = 0. + rif = 0. + alpha = 0. + sm = 0. + zz = 0. + l = 0. +c=================================== + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) + n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) +c n2(ig,k)=0. + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) +c print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k) + + + enddo + enddo + + +c==================================================================== +c Au premier appel, on determine l et q2 de facon iterative. +c iterration pour determiner la longueur de melange + + + if (first.or.iflag_pbl.eq.6) then + do ig=1,ngrid + l0(ig)=10. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 + + enddo + +c print*,'Fin de l initialisation de q2 et l0' + + endif ! first + +c==================================================================== +c Calcul de la longueur de melange. +c==================================================================== + +c Mise a jour de l0 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 +c calcul de l(z) + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + if(first) then + q2(ig,k)=l(ig,k)**2*zz(ig,k) + endif + enddo + enddo + +c==================================================================== +c Yamada 2.0 +c==================================================================== + if (iflag_pbl.eq.6) then + + do k=2,klev + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + enddo + enddo + + + else if (iflag_pbl.eq.7) then +c==================================================================== +c Yamada 2.Fournier +c==================================================================== + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + mpre(ig,k)=sqrt(m2(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + enddo + enddo + + do k=2,klev-1 + do ig=1,ngrid + m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12) + mcstat=sqrt(m2cstat) + +c print*,'M2 L=',k,mpre(ig,k),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (k.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1) + & *cd(ig) + & *( sqrt(u(ig,3)**2+v(ig,3)**2) + & -mcstat/unsdzdec(ig,k) + & -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1)*kmpre(ig,k-1) + & *mpre(ig,k-1) ) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ENDIF +c print*,'T2 L=',k,tmp2 + tmp2=kmcstat + & /( sm(ig,k)/q2(ig,k) ) + & /l(ig,k) + q2(ig,k)=max(tmp2,1.e-12)**(2./3.) +c print*,'Q2 L=',k,q2(ig,k) +c + enddo + enddo + + else if (iflag_pbl.ge.8) then +c==================================================================== +c Yamada 2.5 a la Didi +c==================================================================== + + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + if (delta(ig,k).lt.1.e-20) then +c print*,'ATTENTION L=',k,' Delta=',delta(ig,k) + delta(ig,k)=1.e-20 + endif + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + aa0= + s (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1) + aa1= + s (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1) +c abder print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20) + aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + qpre=sqrt(q2(ig,k)) + if (iflag_pbl.eq.8 ) then + if (aa(ig,k).gt.0.) then + q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + else ! iflag_pbl=9 + if (aa(ig,k)*qpre.gt.0.9) then + q2(ig,k)=(qpre*10.)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + endif + q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4) +c print*,'Q2 L=',k,q2(ig,k),qpre*qpre + enddo + enddo + + endif ! Fin du cas 8 + +c print*,'OK8' + +c==================================================================== +c Calcul des coefficients de mélange +c==================================================================== + do k=2,klev +c print*,'k=',k + do ig=1,ngrid +cabde print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k) + zq=sqrt(q2(ig,k)) + km(ig,k)=l(ig,k)*zq*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + kq(ig,k)=l(ig,k)*zq*0.2 +c print*,'KML=',km(ig,k),kn(ig,k) + enddo + enddo + +c if (iflag_pbl.ge.7..and.0.eq.1) then +c q2(:,1)=q2(:,2) +c call vdif_q2(dt,g,rconst,plev,temp,kq,q2) +c endif + +c Traitement des cas noctrunes avec l'introduction d'une longueur +c minilale. + +c==================================================================== +c Traitement particulier pour les cas tres stables. +c D'apres Holtslag Boville. + +c print*,'YAMADA4 0' + + do ig=1,ngrid + coriol(ig)=1.e-4*86400/RDAY !! scaling... should be checked + pblhmin(ig)=0.07*ustar(ig)/ + . max(abs(coriol(ig)),2.546e-5*86400/RDAY) + enddo +c if (first) then +c print*,'A REVOIR!! coriol ?? pblhmin ',pblhmin +c endif +CTest a remettre 21 11 02 +c test abd 13 05 02 if(0.eq.1) then + if(1.eq.1) then + do k=2,klev + do ig=1,klon + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=-1. ! kmin n'est utilise que pour les SL stables. + endif + if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then +c print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k) +c s ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k) + kn(ig,k)=kmin + km(ig,k)=kmin + kq(ig,k)=kmin +c la longueur de melange est suposee etre l= kap z +c K=l q Sm d'ou q2=(K/l Sm)**2 + q2(ig,k)=(qmin/sm(ig,k))**2 + endif + enddo + enddo + endif + +c print*,'YAMADA4 1' + +c Estimations de w'2 et T'2 d'apres Abdela et McFarlane + +c if(1.eq.0)then +c w2yam=q2(:,1:klev)*0.24 +c s +lyam(:,1:klev)*5.17*kn(:,1:klev)*n2(:,1:klev) +c s /sqrt(q2(:,1:klev)) +c +c t2yam=9.1*kn(:,1:klev)*dtetadz(:,1:klev)**2/sqrt(q2(:,1:klev)) +c s *lyam(:,1:klev) +c endif + +c print*,'OKFIN' + first=.false. + return + end Index: trunk/LMDZ.TITAN.old/libf/phytitan/zenang.F =================================================================== --- trunk/LMDZ.TITAN.old/libf/phytitan/zenang.F (revision 1643) +++ trunk/LMDZ.TITAN.old/libf/phytitan/zenang.F (revision 1643) @@ -0,0 +1,156 @@ +c==================================================================== + SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long, + s pmu0,frac) +c============================================================= +c Auteur : O. Boucher (LMD/CNRS) +c d'apres les routines zenith et angle de Z.X. Li +c Objet : calculer les valeurs moyennes du cos de l'angle zenithal +c et l'ensoleillement moyen entre gmtime1 et gmtime2 +c connaissant la declinaison, la latitude et la longitude. +c Rque : Different de la routine angle en ce sens que zenang +c fournit des moyennes de pmu0 et non des valeurs +c instantanees, du coup frac prend toutes les valeurs +c entre 0 et 1. +c Date : premiere version le 13 decembre 1994 +c revu pour GCM le 30 septembre 1996 +c=============================================================== +c longi----INPUT : la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c gmtime---INPUT : temps universel en fraction de jour +c pdtrad---INPUT : pas de temps du rayonnement (secondes) +c lat------INPUT : latitude en degres +c long-----INPUT : longitude en degres +c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+(pdtrad/RDAY) +c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+(pdtrad/RDAY) +c================================================================ + use dimphy + IMPLICIT none +#include "YOMCST.h" +#include "comorbit.h" +c================================================================ + real longi, gmtime, pdtrad + real lat(klon), long(klon), pmu0(klon), frac(klon) +c================================================================ + integer i + real gmtime1, gmtime2 + real pi_local, deux_pi_local, incl + real omega1, omega2, omega +c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. +c omega : heure en radian du coucher de soleil +c -omega est donc l'heure en radian de lever du soleil + real omegadeb, omegafin + real zfrac1, zfrac2, z1_mu, z2_mu + real lat_sun ! declinaison en radian + real lon_sun ! longitude solaire en radian + real latr ! latitude du pt de grille en radian +c================================================================ +c + pi_local = 4.0 * ATAN(1.0) + deux_pi_local = 2.0 * pi_local + incl=obliquit * pi_local / 180. +c + lon_sun = longi * pi_local / 180.0 + lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) +c + gmtime1=gmtime*RDAY + gmtime2=gmtime*RDAY+pdtrad +c + DO i = 1, klon +c + latr = lat(i) * pi_local / 180. +c +c--pose probleme quand lat=+/-90 degres +c +c omega = -TAN(latr)*TAN(lat_sun) +c omega = ACOS(omega) +c IF (latr.GE.(pi_local/2.+lat_sun) +c . .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN +c omega = 0.0 ! nuit polaire +c ENDIF +c IF (latr.GE.(pi_local/2.-lat_sun) +c . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN +c omega = pi_local ! journee polaire +c ENDIF +c +c--remplace par cela (le cas par defaut est different) +c + omega=0.0 !--nuit polaire + IF (latr.GE.(pi_local/2.-lat_sun) + . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + ENDIF + IF (latr.LT.(pi_local/2.+lat_sun).AND. + . latr.GT.(-pi_local/2.+lat_sun).AND. + . latr.LT.(pi_local/2.-lat_sun).AND. + . latr.GT.(-pi_local/2.-lat_sun)) THEN + omega = -TAN(latr)*TAN(lat_sun) + omega = ACOS(omega) + ENDIF +c + omega1 = gmtime1 + long(i)*RDAY/360.0 + omega1 = omega1 / RDAY*deux_pi_local + omega1 = MOD (omega1+deux_pi_local, deux_pi_local) + omega1 = omega1 - pi_local +c + omega2 = gmtime2 + long(i)*RDAY/360.0 + omega2 = omega2 / RDAY*deux_pi_local + omega2 = MOD (omega2+deux_pi_local, deux_pi_local) + omega2 = omega2 - pi_local +c + IF (omega1.LE.omega2) THEN !--on est dans la meme journee locale +c + IF (omega2.LE.-omega .OR. omega1.GE.omega + . .OR. omega.LT.1e-5) THEN !--nuit + frac(i)=0.0 + pmu0(i)=0.0 + ELSE !--jour+nuit/jour + omegadeb=MAX(-omega,omega1) + omegafin=MIN(omega,omega2) + frac(i)=(omegafin-omegadeb)/(omega2-omega1) + pmu0(i)=SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c + ELSE !---omega1 GT omega2 -- a cheval sur deux journees +c +c-------------------entre omega1 et pi + IF (omega1.GE.omega) THEN !--nuit + zfrac1=0.0 + z1_mu =0.0 + ELSE !--jour+nuit + omegadeb=MAX(-omega,omega1) + omegafin=omega + zfrac1=omegafin-omegadeb + z1_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c---------------------entre -pi et omega2 + IF (omega2.LE.-omega) THEN !--nuit + zfrac2=0.0 + z2_mu =0.0 + ELSE !--jour+nuit + omegadeb=-omega + omegafin=MIN(omega,omega2) + zfrac2=omegafin-omegadeb + z2_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) +c + ENDIF +c-----------------------moyenne + frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) + pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10) +c + ENDIF !---comparaison omega1 et omega2 +c +c Petit test rajoute pour les cas pathologiques aux poles + if (pmu0(i).lt.0.) pmu0(i) = -1.*pmu0(i) + + ENDDO +c + END Index: trunk/LMDZ.TITAN.old/makelmdz =================================================================== --- trunk/LMDZ.TITAN.old/makelmdz (revision 1643) +++ trunk/LMDZ.TITAN.old/makelmdz (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/makelmdz Index: trunk/LMDZ.TITAN.old/makelmdz_fcm =================================================================== --- trunk/LMDZ.TITAN.old/makelmdz_fcm (revision 1643) +++ trunk/LMDZ.TITAN.old/makelmdz_fcm (revision 1643) @@ -0,0 +1,1 @@ +link ../LMDZ.COMMON/makelmdz_fcm