SUBROUTINE RADTITAN(p,nq,nmicro,ycomp) IMPLICIT NONE 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 ------------- #include "dimensions.h" #include "dimphy.h" #include "clesphys.h" #include "microtab.h" #include "numchimrad.h" #include "comgeomphy.h" #include "YOMCST.h" #include "advtrac.h" !! pour noms des traceurs 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 Arguments: c ---------- INTEGER nq,nmicro REAL p(klon,nlevel) REAL ycomp(klon,nlayer,nq) c Local: c ------ INTEGER I,J,IG,K,IPRINT INTEGER IPREM LOGICAL notfirstcall SAVE IPREM,notfirstcall data notfirstcall/.false./ REAL emu,somcoslat,coslat(klon) REAL PCH4, effg,FH2L,RHCH4L,SSUM ! effg est une fonction(z) c COMMONS for interface with local subroutines: c --------------------------------------------- REAL DTAUP(klon,NLAYER,NSPECI) REAL UBARI,UBARV,UBAR0 REAL DZED(NLAYER) REAL Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) REAL DTDP(NLAYER),CONVEQ REAL CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) REAL XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) REAL C2H2(NLAYER),C2H6(NLAYER),HCN(NLAYER) REAL SOLARF(NSPECV),PEXPON(NSPECV),ATERM(4,NSPECV) INTEGER NTERM(NSPECV) REAL BTERM(4,NSPECV) REAL RADIUS(NLAYER), XNUMB(NLAYER),REALI(NSPECI), XIMGI(NSPECI) REAL REALV(NSPECV), XIMGV(NSPECV) REAL RADCLD(NLAYER), XNCLD(NLAYER),RCLDI(NSPECI), XICLDI(NSPECI) REAL RCLDV(NSPECV), XICLDV(NSPECV) REAL TAUHI(klon,NSPECI),TAUCI(klon,NSPECI) REAL TAUGI(klon,NSPECI), TAUGV(klon,NSPECV) REAL TAURV(klon,NSPECV),TAUHV(klon,NSPECV) REAL TAUCV(klon,NSPECV) c REAL DTAUI(klon,NLAYER,NSPECI) REAL TAUI(klon,NLEVEL,NSPECI) REAL WBARI(klon,NLAYER,NSPECI) REAL COSBI(klon,NLAYER,NSPECI) REAL BWNI(NSPC1I),WNOI(NSPECI) REAL WLNI(NSPECI),DWNI(NSPECI) c REAL DTAUV(klon,NLAYER,NSPECV,4) REAL TAUV(klon,NLEVEL,NSPECV,4) REAL WBARV(klon,NLAYER,NSPECV,4) REAL COSBV(klon,NLAYER,NSPECV,4) REAL BWNV(NSPC1V), WNOV(NSPECV),DWNV(NSPECV), WLNV(NSPECV) REAL FNETV(klon,NLEVEL),FUPV(klon,NLEVEL,NSPECV) REAL FDV(klon,NLEVEL,NSPECV),FMNETV(klon,NLEVEL) REAL FMUPV(NLEVEL),FMDV(NLEVEL) REAL FNET(klon,NLEVEL),FMNET(klon,NLEVEL) REAL THEAT(klon,NLAYER) REAL CSUBP,RSFI,RSFV,F0PI REAL RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON REAL RGAS,RHOP,PII,SIGMA REAL TIDAL COMMON /IRTAUS/ DTAUP COMMON /VERTICAL/ DZED COMMON /ATM/ Z,PRESS & ,DEN,TEMP COMMON /LAPSE/ DTDP,CONVEQ COMMON /UBARED/ UBARI,UBARV,UBAR0 COMMON /GASS/ CH4,XN2 & ,H2,AR & ,XMU,GAS1 & ,COLDEN COMMON /STRATO/ C2H2,C2H6 COMMON /STRAT2/ HCN COMMON /VISGAS/ SOLARF,NTERM & ,PEXPON,ATERM & ,BTERM COMMON /AERSOL/ RADIUS, XNUMB & ,REALI, XIMGI & ,REALV, XIMGV COMMON /CLOUD/ RADCLD, XNCLD & , RCLDI, XICLDI & , RCLDV, XICLDV COMMON /TAUS/ TAUHI,TAUCI, & TAUGI, TAUGV, & TAURV,TAUHV, & TAUCV * INFRARED CHARACTERISTICS *------------------------------ COMMON /SPECTI/ BWNI,WNOI & ,DWNI,WLNI COMMON /OPTICI/ DTAUI, & TAUI, & WBARI, & COSBI * VISIBLE CHARACTERISTICS *------------------------------ COMMON /OPTICV/ DTAUV & ,TAUV & ,WBARV & ,COSBV COMMON /SPECTV/ BWNV, WNOV & ,DWNV, WLNV COMMON /FLUXvV/ FNETV, & FUPV, & FDV, & FMNETV COMMON /FLUX/ FNET, FMNET & ,THEAT COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON COMMON /CONST/RGAS,RHOP,PII,SIGMA COMMON /IO/ TIDAL * common relatifs aux aerosols * nrad dans microtab.h REAL qaer(klon,nlayer,nqmx),volume(nrad),rayon(nrad),vrat, & drayon(nrad),dvolume(nrad) common/traceurs/qaer common/part/volume,rayon,vrat, & drayon,dvolume c----------------------------------------------------------------------- c 1. Initialisations: c ------------------- REAL xpoub,kkk,xvis,xir 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 MODIFY ADJUSTABLE NUMBERS HERE -- NOT IN COMMON C&& FHAZE=0.3 C&& if(iprem.eq.0) then TAUFAC=0 FHVIS=2.0 FHIR=.2 print*,'ouverture du fichier initpar' open (unit=1,file='initpar') read(1,*) xpoub,kkk,xvis,xir close(1) FHVIS= xvis FHIR = xir print*,'ouverture du fichier initpar ok' print*,'DANS RADTITAN' print*,'-------------' print*,'FHVIS = ',FHVIS print*,'FHIR = ',FHIR 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 DO 210 J=1,NLEVEL PRESS(J)=SSUM(klon,p(1,j),1)/FLOAT(klon) 210 CONTINUE IF(press(nlevel-1).GE.1.44) then STOP'pression au sol trop grande' PRINT*,'pression au sol trop grande' endif c PRESS(nlevel)=1.44 c XCORR=1.44/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 (tnom(i).eq."CH4") then iradch4=i elseif (tnom(i).eq."C2H2") then iradc2h2=i elseif (tnom(i).eq."C2H6") then iradc2h6=i elseif (tnom(i).eq."HCN") then iradhcn=i elseif (tnom(i).eq."N2") then iradn2=i elseif (tnom(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(rlatd(j)*RPI/180.) somcoslat=somcoslat+coslat(j) enddo do i=1,nlayer colden(i)=rhop*(press(i+1)-press(i))/effg(z(i)) 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,nmicro,IPRINT) ! #1 print*,'On sort de optci' 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) 230 CONTINUE 220 CONTINUE 225 CONTINUE C NOW, THIS COMPUTATION IS DONE FOR EACH VALUE OF klon C INFRARED. AND THEN IN THE VISIBLE. CALL OPTCV(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.eq.1).or.(.not.ylellouch)) THEN IF(notfirstcall) THEN !F au 1er appel T aux autres appels!! print*,'aerosol/gas/cloud properties' CALL OPTCI(ycomp,nmicro,IPRINT) ! #1 DO IG=1,klon DO J=1,NLAYER DO K=1,NSPECI DTAUP(IG,J,K)=DTAUI(IG,J,K) ENDDO ENDDO ENDDO ENDIF ENDIF c ni optcv si microfi=0 IF (MICROFI.eq.1) THEN IF(notfirstcall) THEN !F au 1er appel T aux autres appels!! print*,'aerosol/gas/cloud properties' CALL OPTCV(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