| 1 | SUBROUTINE aerave_new ( ndata, |
|---|
| 2 | & longdata,epdata,omegdata,gdata, |
|---|
| 3 | & longref,epref,temp,nir,longir |
|---|
| 4 | & ,epir,omegir,gir,qref,omegaref ) |
|---|
| 5 | |
|---|
| 6 | |
|---|
| 7 | IMPLICIT NONE |
|---|
| 8 | c....................................................................... |
|---|
| 9 | c |
|---|
| 10 | c R.Fournier 02/1996 |
|---|
| 11 | c (modif F.Forget 02/1996) |
|---|
| 12 | c le spectre est decoupe en "nir" bandes et cette routine calcule |
|---|
| 13 | c les donnees radiatives moyenne sur chaque bande : l'optimisation |
|---|
| 14 | c est faite pour une temperature au sol "temp" et une epaisseur |
|---|
| 15 | c optique de l'atmosphere "epref" a la longueur d'onde "longref" |
|---|
| 16 | c |
|---|
| 17 | c dans la version actuelle, les ponderations sont independantes de |
|---|
| 18 | c l'epaisseur optique : c'est a dire que "omegir", "gir" |
|---|
| 19 | c et "epir/epre" sont independants de "epref". |
|---|
| 20 | c en effet les ponderations sont choisies pour une solution exacte |
|---|
| 21 | c en couche mince et milieu isotherme. |
|---|
| 22 | c |
|---|
| 23 | c entree |
|---|
| 24 | c |
|---|
| 25 | c ndata : taille des champs data |
|---|
| 26 | c longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol |
|---|
| 27 | c (longdata longueur d'onde en METRES) |
|---|
| 28 | c * longref : longueur d'onde a laquelle l'epaisseur optique |
|---|
| 29 | c est connue |
|---|
| 30 | c * epref : epaisseur optique a longref |
|---|
| 31 | c * temp : temperature choisie pour la ponderation (Planck) |
|---|
| 32 | c * nir : nombre d'intervals dans la discretisation spectrale |
|---|
| 33 | c du GCM |
|---|
| 34 | c * longir : longueurs d'onde definissant ces intervals |
|---|
| 35 | c |
|---|
| 36 | c sortie |
|---|
| 37 | c |
|---|
| 38 | c * epir : epaisseur optique moyenne pour chaque interval |
|---|
| 39 | c * omegir : "scattering albedo" moyen pour chaque interval |
|---|
| 40 | c * gir : "assymetry factor" moyen pour chaque interval |
|---|
| 41 | c * qref : extinction coefficient at reference wavelength |
|---|
| 42 | c * omegaref : single scat. albedo at reference wavelength |
|---|
| 43 | c |
|---|
| 44 | c....................................................................... |
|---|
| 45 | c |
|---|
| 46 | REAL longref |
|---|
| 47 | REAL epref |
|---|
| 48 | REAL temp |
|---|
| 49 | INTEGER nir |
|---|
| 50 | REAL*8 longir(nir+1) |
|---|
| 51 | REAL epir(nir) |
|---|
| 52 | REAL omegir(nir) |
|---|
| 53 | REAL gir(nir) |
|---|
| 54 | c |
|---|
| 55 | c....................................................................... |
|---|
| 56 | c |
|---|
| 57 | INTEGER iir,nirmx |
|---|
| 58 | PARAMETER (nirmx=100) |
|---|
| 59 | INTEGER idata,ndata |
|---|
| 60 | c |
|---|
| 61 | c....................................................................... |
|---|
| 62 | c |
|---|
| 63 | REAL emit |
|---|
| 64 | REAL totalemit(nirmx) |
|---|
| 65 | REAL longdata(ndata),epdata(ndata) |
|---|
| 66 | & ,omegdata(ndata),gdata(ndata) |
|---|
| 67 | REAL qextcorrdata(ndata) |
|---|
| 68 | INTEGER ibande,nbande |
|---|
| 69 | PARAMETER (nbande=1000) |
|---|
| 70 | REAL long,deltalong |
|---|
| 71 | INTEGER ilong |
|---|
| 72 | INTEGER i1,i2 |
|---|
| 73 | REAL c1,c2 |
|---|
| 74 | REAL factep,qextcorr,omeg,g |
|---|
| 75 | REAL qref,omegaref |
|---|
| 76 | c |
|---|
| 77 | c....................................................................... |
|---|
| 78 | c |
|---|
| 79 | DOUBLE PRECISION tmp1 |
|---|
| 80 | REAL tmp2,tmp3 |
|---|
| 81 | c |
|---|
| 82 | c |
|---|
| 83 | long=longref |
|---|
| 84 | |
|---|
| 85 | |
|---|
| 86 | !if(nir.eq.27)then |
|---|
| 87 | !print*,'long',long |
|---|
| 88 | !print*,'longdata',longdata |
|---|
| 89 | !print*,'epdata',epdata |
|---|
| 90 | !print*,'omegdata',omegdata |
|---|
| 91 | !print*,'gdata',gdata |
|---|
| 92 | !print*,'data looks aok!' |
|---|
| 93 | |
|---|
| 94 | !print*,'ndata=',ndata |
|---|
| 95 | !print*,'longdata',shape(longdata) |
|---|
| 96 | !print*,'epdata',shape(epdata) |
|---|
| 97 | !print*,'omegdata',shape(omegdata) |
|---|
| 98 | !print*,'gdata',shape(gdata) |
|---|
| 99 | ! print*,'longref',longref |
|---|
| 100 | !print*,'epref',epref |
|---|
| 101 | !print*,'temp',temp |
|---|
| 102 | !print*,'nir',nir |
|---|
| 103 | !print*,'longir',longir |
|---|
| 104 | !print*,'epir',epir |
|---|
| 105 | !print*,'omegir',gir |
|---|
| 106 | !print*,'qref',qref |
|---|
| 107 | !print*,'longir=',longir |
|---|
| 108 | !stop |
|---|
| 109 | !endif |
|---|
| 110 | |
|---|
| 111 | |
|---|
| 112 | c******************************************************** |
|---|
| 113 | c interpolation |
|---|
| 114 | ilong=1 |
|---|
| 115 | DO idata=2,ndata |
|---|
| 116 | IF (long.gt.longdata(idata)) ilong=idata |
|---|
| 117 | ENDDO |
|---|
| 118 | i1=ilong |
|---|
| 119 | i2=ilong+1 |
|---|
| 120 | IF (i2.gt.ndata) i2=ndata |
|---|
| 121 | IF (long.lt.longdata(1)) i2=1 |
|---|
| 122 | IF (i1.eq.i2) THEN |
|---|
| 123 | c1=1.E+0 |
|---|
| 124 | c2=0.E+0 |
|---|
| 125 | ELSE |
|---|
| 126 | c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) |
|---|
| 127 | c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) |
|---|
| 128 | ENDIF |
|---|
| 129 | c******************************************************** |
|---|
| 130 | c |
|---|
| 131 | qref=c1*epdata(i1)+c2*epdata(i2) |
|---|
| 132 | omegaref=c1*omegdata(i1)+c2*omegdata(i2) |
|---|
| 133 | factep=qref/epref |
|---|
| 134 | DO idata=1,ndata |
|---|
| 135 | qextcorrdata(idata)=epdata(idata)/factep |
|---|
| 136 | ENDDO |
|---|
| 137 | c |
|---|
| 138 | c....................................................................... |
|---|
| 139 | c |
|---|
| 140 | c write(*,*) 'TB17 : nb wl nir,nbande=',nir,nbande |
|---|
| 141 | DO iir=1,nir |
|---|
| 142 | c |
|---|
| 143 | c....................................................................... |
|---|
| 144 | c |
|---|
| 145 | deltalong=(longir(iir+1)-longir(iir)) / nbande |
|---|
| 146 | totalemit(iir)=0.E+0 |
|---|
| 147 | epir(iir)=0.E+0 |
|---|
| 148 | omegir(iir)=0.E+0 |
|---|
| 149 | gir(iir)=0.E+0 |
|---|
| 150 | c |
|---|
| 151 | c....................................................................... |
|---|
| 152 | c |
|---|
| 153 | DO ibande=1,nbande |
|---|
| 154 | c |
|---|
| 155 | c....................................................................... |
|---|
| 156 | c |
|---|
| 157 | long=longir(iir) + (ibande-0.5E+0) * deltalong |
|---|
| 158 | CALL blackl(DBLE(long),DBLE(temp),tmp1) |
|---|
| 159 | emit=REAL(tmp1) |
|---|
| 160 | c |
|---|
| 161 | c....................................................................... |
|---|
| 162 | c |
|---|
| 163 | c******************************************************** |
|---|
| 164 | c interpolation |
|---|
| 165 | ilong=1 |
|---|
| 166 | DO idata=2,ndata |
|---|
| 167 | IF (long.gt.longdata(idata)) ilong=idata |
|---|
| 168 | ENDDO |
|---|
| 169 | i1=ilong |
|---|
| 170 | i2=ilong+1 |
|---|
| 171 | IF (i2.gt.ndata) i2=ndata |
|---|
| 172 | IF (long.lt.longdata(1)) i2=1 |
|---|
| 173 | IF (i1.eq.i2) THEN |
|---|
| 174 | c1=1.E+0 |
|---|
| 175 | c2=0.E+0 |
|---|
| 176 | ELSE |
|---|
| 177 | c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) |
|---|
| 178 | c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) |
|---|
| 179 | ENDIF |
|---|
| 180 | c******************************************************** |
|---|
| 181 | c |
|---|
| 182 | qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2) |
|---|
| 183 | omeg=c1*omegdata(i1)+c2*omegdata(i2) |
|---|
| 184 | g=c1*gdata(i1)+c2*gdata(i2) |
|---|
| 185 | c |
|---|
| 186 | c....................................................................... |
|---|
| 187 | c |
|---|
| 188 | c write(*,*) 'TB17:dtlong,emit,qcorr=',deltalong, emit,qextcorr |
|---|
| 189 | totalemit(iir)=totalemit(iir)+deltalong*emit |
|---|
| 190 | epir(iir)=epir(iir)+deltalong*emit*qextcorr |
|---|
| 191 | omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr |
|---|
| 192 | gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g |
|---|
| 193 | c |
|---|
| 194 | c....................................................................... |
|---|
| 195 | c |
|---|
| 196 | ENDDO |
|---|
| 197 | c |
|---|
| 198 | c....................................................................... |
|---|
| 199 | c |
|---|
| 200 | gir(iir)=gir(iir)/omegir(iir) |
|---|
| 201 | omegir(iir)=omegir(iir)/epir(iir) |
|---|
| 202 | epir(iir)=epir(iir)/totalemit(iir) |
|---|
| 203 | c |
|---|
| 204 | c....................................................................... |
|---|
| 205 | c |
|---|
| 206 | ENDDO |
|---|
| 207 | c |
|---|
| 208 | c...................................................................... |
|---|
| 209 | c |
|---|
| 210 | c Diagnostic de controle si on moyenne sur tout le spectre vis ou IR : |
|---|
| 211 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
|---|
| 212 | c tmp2=0.E+0 |
|---|
| 213 | c DO iir=1,nir |
|---|
| 214 | c tmp2=tmp2+totalemit(iir) |
|---|
| 215 | c ENDDO |
|---|
| 216 | c tmp3=5.67E-8 * temp**4 |
|---|
| 217 | c IF (abs((tmp2-tmp3)/tmp3).gt.0.05E+0) THEN |
|---|
| 218 | c PRINT *,'!!!! <---> il manque du Planck (voir moyenne.F)' |
|---|
| 219 | c PRINT *,'somme des bandes :',tmp2,'--- Planck:',tmp3 |
|---|
| 220 | c ENDIF |
|---|
| 221 | c |
|---|
| 222 | c...................................................................... |
|---|
| 223 | c |
|---|
| 224 | RETURN |
|---|
| 225 | END |
|---|
