[3] | 1 | SUBROUTINE OPTCV(nmicro,IPRINT) |
---|
| 2 | |
---|
| 3 | |
---|
| 4 | #include "dimensions.h" |
---|
| 5 | #include "dimphy.h" |
---|
| 6 | #include "microtab.h" |
---|
| 7 | #include "clesphys.h" |
---|
| 8 | |
---|
| 9 | c Argument: |
---|
| 10 | c --------- |
---|
| 11 | integer nmicro |
---|
| 12 | c --------- |
---|
| 13 | |
---|
| 14 | PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) |
---|
| 15 | PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) |
---|
| 16 | |
---|
| 17 | COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) |
---|
| 18 | |
---|
| 19 | COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) |
---|
| 20 | & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) |
---|
| 21 | |
---|
| 22 | COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV), |
---|
| 23 | & ATERM(4,NSPECV),BTERM(4,NSPECV) |
---|
| 24 | |
---|
| 25 | COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) |
---|
| 26 | & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) |
---|
| 27 | |
---|
| 28 | COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER) |
---|
| 29 | & , RCLDI(NSPECI), XICLDI(NSPECI) |
---|
| 30 | & , RCLDV(NSPECV), XICLDV(NSPECV) |
---|
| 31 | |
---|
| 32 | COMMON /TAUS/ TAUHI(klon,NSPECI), TAUCI(klon,NSPECI) |
---|
| 33 | & ,TAUGI(klon,NSPECI), TAURV(klon,NSPECV) |
---|
| 34 | & ,TAUHV(klon,NSPECV) ,TAUCV(klon,NSPECV) |
---|
| 35 | & ,TAUGV(klon,NSPECV) |
---|
| 36 | |
---|
| 37 | COMMON /TAUD/ TAUHID(klon,NLAYER,NSPECI) |
---|
| 38 | & ,TAUGID(klon,NLAYER,NSPECI) |
---|
| 39 | & ,TAUHVD(klon,NLAYER,NSPECV) |
---|
| 40 | & ,TAUGVD(klon,NLAYER,NSPECV) |
---|
| 41 | |
---|
| 42 | COMMON /OPTICV/ DTAUV(klon,NLAYER,NSPECV,4) |
---|
| 43 | & ,TAUV(klon,NLEVEL,NSPECV,4) |
---|
| 44 | & ,WBARV(klon,NLAYER,NSPECV,4) |
---|
| 45 | & ,COSBV(klon,NLAYER,NSPECV,4) |
---|
| 46 | |
---|
| 47 | COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) |
---|
| 48 | & ,DWNV(NSPECV),WLNV(NSPECV) |
---|
| 49 | |
---|
| 50 | COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI |
---|
| 51 | COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON |
---|
| 52 | COMMON /CONST/ RGAS,RHOP,PI,SIGMA |
---|
| 53 | COMMON /traceurs/qaer(klon,nlayer,nqmx) |
---|
| 54 | COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad) |
---|
| 55 | |
---|
| 56 | REAL xv1(klev,NSPECV) |
---|
| 57 | REAL xv2(klev,NSPECV) |
---|
| 58 | REAL xv3(klev,NSPECV) |
---|
| 59 | |
---|
| 60 | REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV) |
---|
| 61 | REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV) |
---|
| 62 | REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV) |
---|
| 63 | REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV) |
---|
| 64 | |
---|
| 65 | save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 |
---|
| 66 | |
---|
| 67 | integer ioptv,iwarning ! ioptv: premier appel, une seule boucle sur les l.d'o. |
---|
| 68 | integer ig_,seulmtunpt |
---|
| 69 | save ioptv,iwarning,seulmtunpt |
---|
| 70 | data ioptv,iwarning,seulmtunpt/0,0,0/ |
---|
| 71 | |
---|
| 72 | real zqaer_1pt(NLAYER,nrad) |
---|
| 73 | real TAUHVD_1pt(NLAYER,NSPECV) |
---|
| 74 | real TAUGVD_1pt(NLAYER,NSPECV) |
---|
| 75 | real TAUHV_1pt(NSPECV),TAUCV_1pt(NSPECV) |
---|
| 76 | real TAURV_1pt(NSPECV),TAUGV_1pt(NSPECV) |
---|
| 77 | real DTAUV_1pt(NLAYER,NSPECV,4),TAUV_1pt(NLEVEL,NSPECV,4) |
---|
| 78 | real WBARV_1pt(NLAYER,NSPECV,4) |
---|
| 79 | real COSBV_1pt(NLAYER,NSPECV,4) |
---|
| 80 | character*100 dummy |
---|
| 81 | real dummy2,dummy3 |
---|
| 82 | |
---|
| 83 | C* |
---|
| 84 | C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE |
---|
| 85 | C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS |
---|
| 86 | C LAYER: WBAR, DTAU, COSBAR |
---|
| 87 | C LEVEL: TAU |
---|
| 88 | C |
---|
| 89 | sum=0. |
---|
| 90 | PRINT*,'OPTCV' |
---|
| 91 | print*,'ATTENTION, TAU UNIFORME DANS OPTCV' |
---|
| 92 | |
---|
| 93 | c do nng=2,klon |
---|
| 94 | c do i=1,klev |
---|
| 95 | c do j=1,nqmx |
---|
| 96 | c sum=sum+qaer(nng,i,j)*rayon(j)**3.*1.3333*3.1415*1000. |
---|
| 97 | c enddo |
---|
| 98 | c enddo |
---|
| 99 | c enddo |
---|
| 100 | c print*,sum/(klon-1),'SOMME COLONNE/OPTCV' |
---|
| 101 | |
---|
| 102 | |
---|
| 103 | C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
---|
| 104 | c INITIALISATIONS UNE SEULE FOIS |
---|
| 105 | C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
---|
| 106 | |
---|
| 107 | if (ioptv.eq.0) then |
---|
| 108 | |
---|
| 109 | c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqmx=1, |
---|
| 110 | c il faut quand meme qu'on lise la look-up table de dim nrad=10 |
---|
| 111 | c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h) |
---|
| 112 | if ((nmicro.ne.nrad).and.(microfi.eq.1)) then |
---|
| 113 | print*,"nmicro.ne.nrad",nmicro,nrad |
---|
| 114 | print*,"PROBLEME pour zqaer_1pt dans optcv !!" |
---|
| 115 | stop |
---|
| 116 | endif |
---|
| 117 | |
---|
| 118 | |
---|
| 119 | DO 130 K=1,NSPECV |
---|
| 120 | C LETS USE THE OPTICAL CONSTANTS FOR THOLIN |
---|
| 121 | CALL THOLIN(WLNV(K),TNR,TNI) |
---|
| 122 | REALV(K)=TNR |
---|
| 123 | XIMGV(K)=TNI*FHVIS |
---|
| 124 | C BUT WE NOW USE THE GEOMETRIC ALBEDO FITTED RESULTS |
---|
| 125 | C XIMGV(K)=FITEDT(WLNV(K)) |
---|
| 126 | C XIMGV(K)=FITEDN(WLNV(K)) |
---|
| 127 | C THE CLOUD IS CLEAR IN THE VISIBLE |
---|
| 128 | RCLDV(K)=1.27 |
---|
| 129 | XICLDV(K)=1.E-7 |
---|
| 130 | 130 CONTINUE |
---|
| 131 | C |
---|
| 132 | c open (unit=1,file='xsetupv') |
---|
| 133 | c do j=1,nspecv |
---|
| 134 | c read(1,*) a |
---|
| 135 | c do i=1,klev |
---|
| 136 | c read(1,*) xv1(i,j),xv2(i,j),xv3(i,j) |
---|
| 137 | c enddo |
---|
| 138 | c enddo |
---|
| 139 | c close(1) |
---|
| 140 | |
---|
| 141 | endif ! fin initialisations premier appel |
---|
| 142 | |
---|
| 143 | c******* DEBUT DES BOUCLE GRILLE ************************ |
---|
| 144 | c PRINT*, 'AEROSOLS EN VISIBLE' |
---|
| 145 | |
---|
| 146 | DO 101 ig=1,klon !c! BOUCLE SUR GRILLE HORIZONTALE |
---|
| 147 | |
---|
| 148 | if (microfi.eq.1) then |
---|
| 149 | do iq=1,nrad |
---|
| 150 | do j=1,NLAYER |
---|
| 151 | zqaer_1pt(j,iq)=qaer(ig,j,iq) |
---|
| 152 | enddo |
---|
| 153 | enddo |
---|
| 154 | else |
---|
| 155 | if (ig.eq.1) then |
---|
| 156 | c initialisation zqaer_1pt a partir d'une look-up table (uniforme en ig) |
---|
| 157 | c boucle sur nrad=10 |
---|
| 158 | open(10,file="qaer_eq_1d.dat") |
---|
| 159 | do iq=1,15 |
---|
| 160 | read(10,'(A100)') dummy |
---|
| 161 | enddo |
---|
| 162 | do j=NLAYER,1,-1 |
---|
| 163 | read(10,*) dummy2,dummy3,(zqaer_1pt(j,iq),iq=1,nrad) |
---|
| 164 | enddo |
---|
| 165 | close(10) |
---|
| 166 | endif |
---|
| 167 | endif |
---|
| 168 | |
---|
| 169 | c if ((ig.eq.klon/2).or.(microfi.eq.0)) then |
---|
| 170 | c print*,"Q01=",zqaer_1pt(:,1) |
---|
| 171 | c print*,"Q05=",zqaer_1pt(:,5) |
---|
| 172 | c print*,"Q10=",zqaer_1pt(:,10) |
---|
| 173 | c stop |
---|
| 174 | c endif |
---|
| 175 | |
---|
| 176 | iout=0 |
---|
| 177 | c if ((microfi.eq.0).or.(ig.eq.klon/2)) iout=1 |
---|
| 178 | if (seulmtunpt.eq.0) then |
---|
| 179 | call optcv_1pt(zqaer_1pt,ioptv, |
---|
| 180 | . COSBV_1pt,DTAUV_1pt,TAUHV_1pt,TAUHVD_1pt,TAUCV_1pt, |
---|
| 181 | . TAURV_1pt,TAUGV_1pt,TAUGVD_1pt,WBARV_1pt,TAUV_1pt,iout) |
---|
| 182 | ioptv = 1 |
---|
| 183 | endif |
---|
| 184 | |
---|
| 185 | c Pas de microphysique, ni de composition variable: un seul passage |
---|
| 186 | c dans optci_1pt. |
---|
| 187 | if ((microfi.eq.0).and.(ylellouch)) then |
---|
| 188 | seulmtunpt = 1 |
---|
| 189 | endif |
---|
| 190 | |
---|
| 191 | COSBV(ig,:,:,:)= COSBV_1pt(:,:,:) |
---|
| 192 | WBARV(ig,:,:,:)= WBARV_1pt(:,:,:) |
---|
| 193 | DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:) |
---|
| 194 | TAUHV(ig,:) = TAUHV_1pt(:) |
---|
| 195 | TAUCV(ig,:) = TAUCV_1pt(:) |
---|
| 196 | TAURV(ig,:) = TAURV_1pt(:) |
---|
| 197 | TAUGV(ig,:) = TAUGV_1pt(:) |
---|
| 198 | TAUV(ig,:,:,:) = TAUV_1pt(:,:,:) |
---|
| 199 | TAUHVD(ig,:,:) = TAUHVD_1pt(:,:) |
---|
| 200 | TAUGVD(ig,:,:) = TAUGVD_1pt(:,:) |
---|
| 201 | |
---|
| 202 | 101 CONTINUE |
---|
| 203 | |
---|
| 204 | c FIN BOUCLE GRILLE ******* |
---|
| 205 | c****************************** |
---|
| 206 | |
---|
| 207 | PRINT*, 'FIN OPTCV' |
---|
| 208 | RETURN |
---|
| 209 | END |
---|