OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
6sm1.f
Go to the documentation of this file.
1  subroutine ssssss
2 c**********************************************************************c
3 c c
4 c c
5 c ******************************************************** c
6 c * second simulation of satellite signal * c
7 c * in the solar spectrum * c
8 c * ... (6s) ....... (6s) ...... (6s) ... * c
9 c * .... (6s) ...... (6s)... * c
10 c * ...... (6s) ...... * c
11 c * version 4.1 * c
12 c * * c
13 c * this code predicts the satellite signal from 0.25 * c
14 c * to 4.0 microns assuming cloudless atmosphere. * c
15 c * the main atmospheric effects (gaseous absorption * c
16 c * by water vapor,carbon dioxyde,oxygen and ozone; * c
17 c * scattering by molecules and aerosols) are taken * c
18 c * into account. non-uniform surfaces may be * c
19 c * considered,as well as bidirectional reflectances * c
20 c * as boundary conditions * c
21 c * * c
22 c * the following input parameters are needed * c
23 c * geometrical conditions * c
24 c * atmospheric model for gaseous components * c
25 c * aerosol model (type and concentration) * c
26 c * spectral condition * c
27 c * ground reflectance (type and spectral var.) * c
28 c * at each step, you can either select some proposed * c
29 c * standard conditions (for example,spectral bands of * c
30 c * satellite for spectral conditions) or define your * c
31 c * own conditions(in the example,you have to define * c
32 c * the assumed spectral response). * c
33 c * * c
34 c * more details are given at each data input step * c
35 c * * c
36 c ******************************************************** c
37 c c
38 c c
39 c**********************************************************************c
40 
41 c**********************************************************************c
42 c c
43 c c
44 c ******************************************************** c
45 c * authors of this code are * c
46 c * * c
47 c * (1) Vermote E.; (2) Tanre D.;(2) Deuze J.L. * c
48 c * (2) Herman M.,(3) MOrcrette J.J.. * c
49 c * * c
50 c * from * c
51 c * * c
52 c * (1) Affiliation: Department of Geography * c
53 c * University of Maryland * c
54 c * address: Goddard Space Flight Center * c
55 c * Code 923 * c
56 c * greenbelt, md 20771 * c
57 c * USA * c
58 c * * c
59 c * (2) laboratoire d' optique atmospherique * c
60 c * universite des sciences et techniques * c
61 c * de lille * c
62 c * u.e.r. de physique fondamentale * c
63 c * 59655 villeneuve d' ascq cedex * c
64 c * france * c
65 c * * c
66 c * (3) e.c.m.w.f. * c
67 c * * c
68 c ******************************************************** c
69 c c
70 c c
71 c**********************************************************************c
72 
73 c**********************************************************************c
74 c ******************************************************** c
75 c * limits of validity * c
76 c * * c
77 c * geometrical parameters solar zenith angle and * c
78 c * satellite zenith angle * c
79 c * must be less than 60 and * c
80 c * 50 degrees respectively. * c
81 c * * c
82 c * atmospheric model no limitations * c
83 c * * c
84 c * aerosol model the visibility must be * c
85 c * better than 5.0km * c
86 c * for smaller values * c
87 c * calculations might be * c
88 c * no more valid. * c
89 c * * c
90 c * spectral conditions the gaseous transmittance* c
91 c * and the scattering func * c
92 c * tions are valid from 0.25* c
93 c * to 4.0 micron. but the * c
94 c * treatment of interaction * c
95 c * between absorption and * c
96 c * scattering is correct for* c
97 c * not too large absorption * c
98 c * if you want to compute * c
99 c * signal within absorption * c
100 c * bands,this interaction * c
101 c * ought to be reconsidered * c
102 c * * c
103 c * ground reflectance (type) you can consider a patchy* c
104 c * structure:that is a circu* c
105 c * lar target of radius rad * c
106 c * and of reflectance roc, * c
107 c * within an environnement * c
108 c * of reflectance roe. * c
109 c * * c
110 c * ground reflectance (type continued): for uniform * c
111 c * surface conditions only, * c
112 c * you may consider directio* c
113 c * nal reflectance as bounda* c
114 c * ry conditions. * c
115 c * some analytical model are* c
116 c * proposed, the user can * c
117 c * specify his own values. * c
118 c * the code assumes that the* c
119 c * brdf is spectrally inde- * c
120 c * pendent * c
121 c * * c
122 c * ground reflectance (spectral variation) four typi * c
123 c * cal reflectances are pro * c
124 c * posed, defined within * c
125 c * given spectral range. * c
126 c * this range differs accor * c
127 c * ding to the selected case* c
128 c * the reflectance is set to* c
129 c * 0 outside this range,due * c
130 c * to the deficiency of data* c
131 c * user must verify these * c
132 c * limits. that is obviously* c
133 c * irrelevant for brdf * c
134 c * * c
135 c ******************************************************** c
136 c**********************************************************************c
137 
138 c****************************************************************************c
139 c for considering brdf< we have to compute the downward radiance in the c
140 c whole hemisphere. to perform such computions, we selected the successive c
141 c orders of scattering method. that method requires numerical integration c
142 c over angles and optical depth. the integration method is the gauss method,c
143 c mu is the number of angles nmu+1, nmu is settled to 24. the accuracy of c
144 c the computations is obviously depending on the nmu value. this value c
145 c can be easily changed as a parameter as well as the nt value which c
146 c is the number of layers for performing the vertical integration. the c
147 c downward radiance is computed for nmu values of the zenith angle and np c
148 c values of the azimuth angle. the integration of the product of the c
149 c radiance by the brdf is so performed over the nmu*np values. np is settledc
150 c to 13, that value can be also changed. mu2 is equal to 2 times nmu. c
151 c xlmus is the downward radiance, xf the downward irradiance, rm and gb c
152 c the angles and the weights for the gauss integration over the zenith, rp c
153 c and bp respectively for the azimuth integration. c
154 c****************************************************************************c
155 C
156 C Added by B.-C. Gao in June 1996
157 C Declarations for common variables
158  dimension hhh(25),ttt(25),ppp(25),vmrr(25)
159  dimension wltemp(1050),rotemp(1050),dttemp(1050),astemp(1050)
160  dimension wavobs(1024),fwhm(1024)
161  dimension rotot(1050), ttot(1050), stot(1050)
162 
163 C Common variables used by 6S
164  COMMON /getinput3/ hhh,ttt,ppp,vmrr,nb,nl,model,iaer,v,taer55,
165  & vrto3,sno2
166  COMMON /getinput4/ wavobs,fwhm
167  COMMON /getinput8/ imnn,idyy,iyrr,ihh,imm,iss
168  COMMON /geometry1/ solzni,solaz,obszni,obsphi,iday
169  COMMON /sixs1/ rotot, ttot, stot
170 C
171 C Parameters for plane observation and for elevated surface scenes,
172 C surface and plane altitudes are in units of km
173  REAL XPSS, XPPP
174  COMMON /getinput14/ xpss, xppp
175 C
176 C Local indecies used in 6S
177  INTEGER JINDEX, NELEM
178 
179 C-- parameter(nt_p=13,mu_p=13,mu2_p=24,np_p=25)
180  parameter(nt_p=26,mu_p=25,mu2_p=48,np_p=49)
181  dimension anglem(mu2_p),weightm(mu2_p),
182  s rm(-mu_p:mu_p),gb(-mu_p:mu_p),rp(np_p),gp(np_p)
183  dimension xlmus(-mu_p:mu_p,np_p),xlmuv(-mu_p:mu_p,np_p)
184  dimension angmu(10),angphi(13),brdfints(-mu_p:mu_p,np_p)
185  s ,brdfdats(10,13),
186  s brdfintv(-mu_p:mu_p,np_p),brdfdatv(10,13),robar(1501),
187  s robarp(1501),robard(1501),xlm1(-mu_p:mu_p,np_p),
188  s xlm2(-mu_p:mu_p,np_p)
189 
190  real anglem,weightm,rm,gb,accu2,accu3
191  real rp,gp,xlmus,xlmuv,angmu,angphi,brdfints,brdfdats
192  real brdfintv,brdfdatv,robar,robarp,robard,xlm1,xlm2
193  real c,wldisc,ani,anr,aini,ainr,rocl,roel,zpl,ppl,tpl,whpl
194  real wopl,xacc,phasel,pdgs,cgaus,pha,betal,s,wlinf,wlsup,delta
195  real sigma,z,p,t,wh,wo,ext,ome,gasym,phase,roatm,dtdir
196  real dtdif,utdir,utdif,sphal,wldis,trayl,traypl,pi,pi2,step
197  real asol,phi0,avis,phiv,tu,xlon,xlat,xlonan,hna,dsol,campm
198  real phi,phirad,xmus,xmuv,xmup,xmud,adif,uw,uo3,taer55
199  real taer,v,xps,uwus,uo3us,xpp,taer55p,puw,puo3,puwus
200  real puo3us,wl,wlmoy,tamoy,tamoyp,pizmoy,pizmoyp,trmoy
201  real trmoyp,fr,rad,spalt
202  real albbrdf,par1,par2,par3,par4,robar1,xnorm1,rob,xnor,rodir
203  real rdown,rdir,robar2,xnorm2,ro,roc,roe,rapp,rocave,roeave
204  real seb,sbor,swl,sb,refet,refet1,refet2,refet3,alumet
205  real tgasm,rog,dgasm,ugasm,sdwava,sdozon,sddica,sdoxyg
206  real sdniox,sdmoca,sdmeth,suwava,suozon,sudica,suoxyg
207  real suniox,sumoca,sumeth,stwava,stozon,stdica,stoxyg,stniox
208  real stmoca,stmeth,sodray,sodaer,sodtot,fophsr,fophsa,sroray
209  real sroaer,srotot,ssdaer,sdtotr,sdtota,sdtott,sutotr,sutota
210  real sutott,sasr,sasa,sast,dtozon,dtdica,dtoxyg
211  real dtniox,dtmeth,dtmoca,utozon,utdica,utoxyg,utniox
212  real utmeth,utmoca,attwava,ttozon,ttdica,ttoxyg,ttniox
213  real ttmeth,ttmoca,dtwava,utwava,ttwava,coef,romix,rorayl
214  real roaero,phaa,phar,tsca,tray,trayp,taerp,dtott,utott
215  real astot,asray,asaer,utotr,utota,dtotr,dtota,dgtot,tgtot
216  real tgp1,tgp2
217  real ugtot,edifr,edifa,tdird,tdiru,tdifd,tdifu,fra
218  real fae,avr,romeas1,romeas2,romeas3,alumeas,sodrayp
219  real ratm1,ratm2,ratm3,rsurf
220  real sodaerp,sodtotp,tdir,tdif,etn,esn,es,ea0n,ea0,ee0n
221  real ee0,tmdir,tmdif,xla0n,xla0,xltn,xlt,xlen,xle,pizera
222  real fophst,pizerr,pizert,xrad,xa,xb,xc
223  real sha,sham
224  integer nt,mu,mu2,np,k,iwr,mum1,idatmp
225  integer j,iread,l,igeom,month,jday,nc,nl,idatm,iaer,iaerp,n
226  integer iwave,iinf,isup,ik,i,inhomo,idirec,ibrdf,igroun
227  integer igrou1,igrou2,isort
228 c***********************************************************************
229 c return to 6s
230 c***********************************************************************
231  dimension c(4),wldisc(10),ani(2,3),anr(2,3),aini(2,3),ainr(2,3)
232  dimension rocl(1501),roel(1501)
233  real rn,ri,x1,x2,x3,cij,rsunph,nrsunph,rmax,rmin
234  integer icp,irsunph,i1,i2
235  character etiq1(8)*60,nsat(47)*17,atmid(7)*51,reflec(8)*71
236  character FILE*80,FILE2*80
237 
238  logical ier
239  common/sixs_ier/iwr,ier
240  common /mie_in/ rmax,rmin,icp,rn(10,4),ri(10,4),x1(4),x2(4),
241  s x3(4),cij(4),irsunph,rsunph(50),nrsunph(50)
242 c***********************************************************************
243 c for considering pixel and sensor altitude
244 c***********************************************************************
245  real pps,palt,ftray
246  common /sixs_planesim/zpl(34),ppl(34),tpl(34),whpl(34),wopl(34)
247  common /sixs_test/xacc
248 c***********************************************************************
249 c for considering brdf
250 c***********************************************************************
251  common /sixs_sos/phasel(10,83),cgaus(83),pdgs(83)
252  common /sixs_trunc/pha(83),betal(0:80)
253  real optics(3),struct(4)
254  integer options(5)
255  integer pild,pihs
256  real pxLt,pc,pRl,pTl,pRs
257  real pws,phi_wind,xsal,pcl,paw
258  real uli,eei,thmi,sli,cabi,cwi,vaii,rnci,rsl1i
259 c***********************************************************************
260 c return to 6s
261 c***********************************************************************
262  common /sixs_ffu/s(1501),wlinf,wlsup
263  common /sixs_del/ delta,sigma
264  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
265  common /sixs_aer/ext(10),ome(10),gasym(10),phase(10)
266  common /sixs_disc/ roatm(3,10),dtdir(3,10),dtdif(3,10),
267  s utdir(3,10),utdif(3,10),sphal(3,10),wldis(10),trayl(10),
268  s traypl(10)
269 
270 
271 c****************************************************************************c
272 c angmu and angphi are the angles were the brdf is measured. these values c
273 c can be changed as soon as they are well distributed over the whole space c
274 c before the gauss integration, these values are interpolated to the gauss c
275 c angles c
276 c****************************************************************************c
277  data angmu /85.0,80.0,70.0,60.0,50.0,40.0,30.0,20.0,10.0,0.00/
278  data angphi/0.00,30.0,60.0,90.0,120.0,150.0,180.0,
279  s 210.0,240.0,270.0,300.0,330.0,360.0/
280 
281 c***********************************************************************
282 c return to 6s
283 c***********************************************************************
284  data wldisc /0.400,0.488,0.515,0.550,0.633,
285  s 0.694,0.860,1.536,2.250,3.750/
286 
287  data etiq1/
288  s '(1h*,22x,34h user defined conditions ,t79,1h*)',
289  s '(1h*,22x,24h meteosat observation ,t79,1h*) ',
290  s '(1h*,22x,25h goes east observation ,t79,1h*) ',
291  s '(1h*,22x,25h goes west observation ,t79,1h*) ',
292  s '(1h*,22x,30h avhrr (AM noaa) observation ,t79,1h*) ',
293  s '(1h*,22x,30h avhrr (PM noaa) observation ,t79,1h*) ',
294  s '(1h*,22x,24h h.r.v. observation ,t79,1h*) ',
295  s '(1h*,22x,24h t.m. observation ,t79,1h*) '/
296 
297  data nsat/
298  s ' constant ',' user s ',
299  s ' meteosat ',' goes east ',' goes west ',
300  s ' avhrr 1 (noaa6) ',' avhrr 2 (noaa6) ',
301  s ' avhrr 1 (noaa7) ',' avhrr 2 (noaa7) ',
302  s ' avhrr 1 (noaa8) ',' avhrr 2 (noaa8) ',
303  s ' avhrr 1 (noaa9) ',' avhrr 2 (noaa9) ',
304  s ' avhrr 1 (noaa10)',' avhrr 2 (noaa10)',
305  s ' avhrr 1 (noaa11)',' avhrr 2 (noaa11)',
306  s ' hrv1 1 ',' hrv1 2 ',' hrv1 3 ',
307  s ' hrv1 pan ',
308  s ' hrv2 1 ',' hrv2 2 ',' hrv2 3 ',
309  s ' hrv2 pan ',
310  s ' tm 1 ',' tm 2 ',' tm 3 ',
311  s ' tm 4 ',' tm 5 ',' tm 7 ',
312  s ' mss 4 ',' mss 5 ',
313  s ' mss 6 ',' mss 7 ',
314  s ' mas 1 ',' mas 2 ',' mas 3 ',
315  s ' mas 4 ',' mas 5 ',' mas 6 ',
316  s ' mas 7 ',' modis 3 ',' modis 5 ',
317  s ' modis 6 ',
318  s ' avhrr 1 (noaa14)',' avhrr 2 (noaa14)'/
319 
320  data atmid /
321  s 'no absorption computed ',
322  s 'tropical (uh2o=4.12g/cm2,uo3=.247cm-atm)',
323  s 'midlatitude summer (uh2o=2.93g/cm2,uo3=.319cm-atm)',
324  s 'midlatitude winter (uh2o=.853g/cm2,uo3=.395cm-atm)',
325  s 'subarctic summer (uh2o=2.10g/cm2,uo3=.480cm-atm)',
326  s 'subarctic winter (uh2o=.419g/cm2,uo3=.480cm-atm)',
327  s 'us standard 1962 (uh2o=1.42g/cm2,uo3=.344cm-atm)'/
328 
329  data reflec /
330  & '(1h*,12x,39h user defined spectral reflectance ,f6.3,t79
331  & ,1h*) ',
332  & '(1h*,12x,27h monochromatic reflectance ,f6.3,t79,1h*)',
333  & '(1h*,12x,39h constant reflectance over the spectra ,f6.3,t79
334  & ,1h*) ',
335  & '(1h*,12x,39h spectral vegetation ground reflectance,f6.3,t79
336  & ,1h*) ',
337  & '(1h*,12x,39h spectral clear water reflectance ,f6.3,t79
338  & ,1h*) ',
339  & '(1h*,12x,39h spectral dry sand ground reflectance ,f6.3,t79
340  & ,1h*) ',
341  & '(1h*,12x,39h spectral lake water reflectance ,f6.3,t79
342  & ,1h*) ',
343  & '(1h*,12x,39h spectral volcanic debris reflectance ,f6.3,t79
344  & ,1h*) '/
345 
346  file=' '
347  file2=' '
348 
349 c***********************************************************************
350 c Parameters initialization
351 c***********************************************************************
352  nt=nt_p
353  mu=mu_p
354  mu2=mu2_p
355  np=np_p
356  iwr=6
357  ier=.false.
358  iinf=1
359  isup=1501
360 c***********************************************************************
361 c preliminary computations for gauss integration
362 c***********************************************************************
363  pi=acos(-1.)
364  pi2=2*pi
365  accu2=1.e-03
366  accu3=1.e-07
367  do k=1,13
368  angphi(k)=angphi(k)*pi/180.
369  enddo
370  do k=1,10
371  angmu(k)=cos(angmu(k)*pi/180.)
372  enddo
373  call gauss(-1.,1.,anglem,weightm,mu2)
374  call gauss(0.,pi2,rp,gp,np)
375  mum1=mu-1
376  do 581 j=-mum1,-1
377  k=mu+j
378  rm(-j-mu)=anglem(k)
379  gb(-j-mu)=weightm(k)
380  581 continue
381  do 582 j=1,mum1
382  k=mum1+j
383  rm(mu-j)=anglem(k)
384  gb(mu-j)=weightm(k)
385  582 continue
386  gb(-mu)=0.
387  gb(0)=0.
388  gb(mu)=0.
389 
390 c***********************************************************************
391 c return to 6s
392 c***********************************************************************
393 c constantes values
394  sigma=0.056032
395  delta=0.0279
396  xacc=1.e-06
397  iread=5
398  step=0.0025
399  do 1111 l=1,10
400  wldis(l)=wldisc(l)
401  1111 continue
402 
403 c**********************************************************************c
404 c igeom geometrical conditions c
405 c -------------------------------------- c
406 c c
407 c c
408 c you choose your own conditions; igeom=0 c
409 c 0 enter solar zenith angle (in degrees ) c
410 c solar azimuth angle " c
411 c satellite zenith angle " c
412 c satellite azimuth angle " c
413 c month c
414 c day of the month c
415 c**********************************************************************c
416 C--- read(iread,*) igeom
417  igeom = 0
418 
419 c igeom=0.....
420 C--- read(iread,*) asol,phi0,avis,phiv,month,jday
421  asol = solzni * 57.2958
422  phi0 = solaz * 57.2958
423  avis = obszni * 57.2958
424  phiv = obsphi * 57.2958
425 C---
426 C--- print*,'ASOL,PHI0,AVIS,PHIV=',ASOL,PHI0,AVIS,PHIV
427 C--- month and jday are used in 6S, but the output calculated
428 C using these quantities are not used in ATREM.
429  month = imnn
430  jday = idyy
431 
432  if(ier) stop
433  dsol=1.
434  call varsol(jday,month,
435  1 dsol)
436 C
437 C-- print*,'dsol = ',dsol
438 
439 c**********************************************************************c
440 c c
441 c / scattered direction c
442 c / c
443 c / c
444 c / adif c
445 c incident + + + + + + + + + + + + + + + c
446 c direction c
447 c c
448 c**********************************************************************c
449  phi=abs(phiv-phi0)
450  phirad=(phi0-phiv)*pi/180.
451  if (phirad.lt.0.) phirad=phirad+2.*pi
452  if (phirad.gt.(2.*pi)) phirad=phirad-2.*pi
453  xmus=cos(asol*pi/180.)
454  xmuv=cos(avis*pi/180.)
455  xmup=cos(phirad)
456  xmud=-xmus*xmuv-sqrt(1.-xmus*xmus)*sqrt(1.-xmuv*xmuv)*xmup
457 c test vermote bug
458  if (xmud.gt.1.) xmud=1.
459  if (xmud.lt.-1.) xmud=-1.
460  adif=acos(xmud)*180./pi
461 
462 c**********************************************************************c
463 c idatm atmospheric model c
464 c -------------------- c
465 c c
466 c c
467 c you select one of the following standard atmosphere: idatm=0 to 6 c
468 c 0 no gaseous absorption c
469 c 1 tropical ) c
470 c 2 midlatitude summer ) c
471 c 3 midlatitude winter ) c
472 c 4 subarctic summer ) from lowtran c
473 c 5 subarctic winter ) c
474 c 6 us standard 62 ) c
475 c c
476 c or you define your own atmospheric model idatm=7 or 8 c
477 c 7 user profile (radiosonde data on 34 levels) c
478 c enter altitude ( in km ) c
479 c pressure ( in mb ) c
480 c temperature ( in k ) c
481 c h2o density (in g/m3) c
482 c o3 density (in g/m3) c
483 c c
484 c for example, altitudes are from 0 to 25km step of 1km c
485 c from 25 to 50km step of 5km c
486 c and two values at 70km and 100km c
487 c so you have 34*5 values to input. c
488 c 8 enter water vapor and ozone contents c
489 c uw (in g/cm2 ) c
490 c uo3 (in cm-atm) c
491 c profil is taken from us62 c
492 c c
493 c**********************************************************************c
494 C--- uw=0.
495 C--- uo3=0.
496 C--- read(iread,*) idatm
497 C--- if(idatm.eq.0) go to 5
498 C--- if(idatm.eq.8) read(iread,*) uw,uo3
499 
500  idatm = model
501 
502 C--uw and uo3 are not used in computing scattering quantities, simply
503 C-- assign values to let the program run.
504  uw = 3.0
505  uo3 = 0.35
506 
507 C***Note: in the final modified code. uw = 0.0, uo3 = 0.0, because
508 C we use 6S only for scattering effect calculations, no
509 C gas absorption is needed.
510 
511 C-- if(idatm.ne.7) go to 6
512 C-- do 7 k=1,34
513 C-- read(iread,*) z(k),p(k),t(k),wh(k),wo(k)
514 C-- 7 continue
515 C-- go to 5
516  if(idatm.EQ.7) idatm = 6
517 
518  6 if(idatm.eq.1) call tropic
519  if(idatm.eq.2) call midsum
520  if(idatm.eq.3) call midwin
521  if(idatm.eq.4) call subsum
522  if(idatm.eq.5) call subwin
523  if(idatm.eq.6) call us62
524 c we have to define an atmosphere to compute rayleigh optical depth
525  5 if(idatm.eq.0.or.idatm.eq.8) call us62
526 
527 
528 c**********************************************************************c
529 c c
530 c iaer aerosol model(type) c
531 c -------------- c
532 c c
533 c c
534 c you select one of the following standard aerosol models: c
535 c 0 no aerosols c
536 c 1 continental model ) c
537 c 2 maritime model ) according to sra models c
538 c 3 urban model ) c
539 c 5 shettle model for background desert aerosol c
540 c 6 biomass burning c
541 c 7 stratospheric model c
542 c c
543 c or you define your own model using basic components: iaer=4 c
544 c 4 enter the volumic percentage of each component c
545 c c(1) = volumic % of dust-like c
546 c c(2) = volumic % of water-soluble c
547 c c(3) = volumic % of oceanic c
548 c c(4) = volumic % of soot c
549 c between 0 to 1 c
550 c c
551 c or you define your own model using size distribution function: c
552 c 8 Multimodal Log Normal distribution (up to 4 modes) c
553 c 9 Modified gamma distribution c
554 c 10 Junge Power-Law distribution c
555 c c
556 c or you define a model using sun-photometer measurements: c
557 c 11 Sun Photometer distribution (50 values max) c
558 c you have to enter: r and d V / d (logr) c
559 c where r is the radius (in micron) and V the volume c
560 c and d V / d (logr) in (cm3/cm2/micron) c
561 c and then you have to enter: nr and ni for each wavelengthc
562 c where nr and ni are respectively the real and c
563 c imaginary part of the refractive index c
564 c c
565 c or you can use results computed and previously saved c
566 c 12 Reading of data previously saved into FILE c
567 c you have to enter the identification name FILE in the c
568 c next line of inputs. c
569 c c
570 c c
571 c iaerp and FILE aerosol model(type)-Printing of results c
572 c --------------------------------------- c
573 c c
574 c For iaer=8,9,10,and 11: c
575 c results from the MIE subroutine may be saved into the file c
576 c FILE.mie (Extinction and scattering coefficients, single c
577 c scattering albedo, Asymmetry parameter, phase function at c
578 c predefined wavelengths) and then can be re-used with the c
579 c option iaer=12 where FILE is an identification name you c
580 c have to enter. c
581 c c
582 c So, if you select iaer=8,9,10,or 11, next line following the c
583 c requested inputs by the options 8,9,10, or 11 you have to enter c
584 c iaerp c
585 c c
586 c iaerp=0 results will not be saved c
587 c iaerp=1 results will be saved into the file FILE.mie c
588 c next line enter FILE c
589 c c
590 c c
591 c example for iaer and iaerp c
592 c 8 Multimodal Log-Normale distribution selected c
593 c 0.0001 100.0 3 Rmin, Rmax, 3 components c
594 c 0.5000 2.99 1.66E-7 Rmean, Sigma, percentage density-1st componentc
595 c 1.53 1.53 1.53 1.53 1.53 1.53 1.52 1.40 1.22 1.27 nr-10 wavelengths c
596 c .008 .008 .008 .008 .008 .008 .008 .008 .009 .011 ni-10 wavelengths c
597 c 0.0050 2.99 0.5945 Rmean, Sigma, percentage density-2nd componentc
598 c 1.53 1.53 1.53 1.53 1.53 1.53 1.52 1.51 1.42 1.452 nr-10 wavelengths c
599 c .005 .005 .005 .005 .006 .007 .012 .023 .010 .004 ni-10 wavelengths c
600 c 0.0118 2.00 0.4055 Rmean, Sigma, percentage density-3rd componentc
601 c 1.75 1.75 1.75 1.75 1.75 1.75 1.75 1.77 1.81 1.90 nr-10 wavelengths c
602 c .46 .45 .45 .44 .43 .43 .43 .46 .50 .57 ni-10 wavelengths c
603 c 1 Results will be saved into FILE.mie c
604 c URBAN-WCP112 Identification of the output file called FILE c
605 c -> results will be saved into URBAN-WCP112.mie c
606 c c
607 c**********************************************************************c
608  rmin=0.
609  rmax=0.
610  icp=1
611  do i=1,4
612  x1(i)=0.0
613  x2(i)=0.0
614  x3(i)=0.0
615  do l=1,10
616  rn(l,i)=0.0
617  ri(l,i)=0.0
618  enddo
619  enddo
620  do i=1,50
621  rsunph(i)=0.
622  nrsunph(i)=0.
623  enddo
624  cij(1)=1.00
625 
626  if(iaer.eq.4) read(iread,*) (c(n),n=1,4)
627  goto(49,40,41,42,49,49,49,49,43,44,45,46,47),iaer+1
628 
629  40 c(1)=0.70
630  c(2)=0.29
631  c(3)=0.00
632  c(4)=0.01
633  go to 49
634  41 c(1)=0.00
635  c(2)=0.05
636  c(3)=0.95
637  c(4)=0.00
638  go to 49
639  42 c(1)=0.17
640  c(2)=0.61
641  c(3)=0.00
642  c(4)=0.22
643  go to 49
644  43 read(iread,*) rmin,rmax,icp
645  do i=1,icp
646  read(5,*)x1(i),x2(i),cij(i)
647  read(5,*)(rn(l,i),l=1,10)
648  read(5,*)(ri(l,i),l=1,10)
649  enddo
650  go to 49
651  44 read(iread,*) rmin,rmax
652  read(iread,*) x1(1),x2(1),x3(1)
653  read(5,*)(rn(l,1),l=1,10)
654  read(5,*)(ri(l,1),l=1,10)
655  go to 49
656  45 read(iread,*) rmin,rmax
657  read(iread,*) x1(1)
658  read(5,*)(rn(l,1),l=1,10)
659  read(5,*)(ri(l,1),l=1,10)
660  go to 49
661  46 read(5,*)irsunph
662  do i=1,irsunph
663  read(5,*)rsunph(i),nrsunph(i)
664  nrsunph(i)=nrsunph(i)/(rsunph(i)**4.)/alog(10.0)
665  enddo
666  rmin=rsunph(1)
667  rmax=rsunph(irsunph)+1e-07
668  read(5,*)(rn(l,1),l=1,10)
669  read(5,*)(ri(l,1),l=1,10)
670  go to 49
671  47 read(5,'(A80)')file2
672  i2=index(file2,' ')-1
673  go to 49
674 
675  49 continue
676  if (iaer.ge.8.and.iaer.le.11)then
677  read(5,*)iaerp
678  if (iaerp.eq.1)read(5,'(A80)')file
679  i1=index(file,' ')-1
680  file2=file(1:i1)//'.mie'
681  i2=index(file2,' ')-1
682  endif
683 
684  call aeroso(iaer,c,xmud,wldis,file2)
685 
686 c**********************************************************************c
687 c aerosol model (concentration) c
688 c ---------------------------- c
689 c c
690 c c
691 c you have an estimate of the meteorological parameter: the visibi c
692 c lity v, c
693 c enter directly the value of v in km(the aerosol optical c
694 c depth will be computed from a standard aerosol profile) c
695 c c
696 c or you have an estimate of aerosol optical depth ,enter v=0 for c
697 c the visibility and enter the aerosol optical depth at 550 c
698 c c
699 c warning: if iaer=0, enter v=-1 c
700 c**********************************************************************c
701  taer55=0.
702  taer=0.
703 C----Temp note: Here another index should be used in the final code.
704 C the current logic is:
705 C READ(iread,*), ID_Taer, Taer55
706 C IF(ID_Taer) 71, 10, 11
707 C in the users manual we should state:
708 C IF(ID_Taer.LT.0), Taer55 must = 0.0
709 C IF(ID_Taer.EQ.0), then v = exp(-log(taer55/2.7628)/0.79902)
710 C IF(ID_Taer.GT.0), then assign v = taer55 and call oda550(iaer,v,taer55)
711 C---End of Temp Note****
712 C-- read(iread,*) v
713 C-- v = 23.
714  if(v) 71,10,11
715  10 read(iread,*) taer55
716  v=exp(-log(taer55/2.7628)/0.79902)
717  goto 71
718  11 call oda550(iaer,v,taer55)
719  71 continue
720 
721 c**********************************************************************c
722 c xps is the parameter to express the altitude of target c
723 c c
724 c c
725 c xps >0. means you know the altitude of the target c
726 c expressed in km and you put that value as xps c
727 c c
728 c c
729 c**********************************************************************c
730  xps = xpss
731 C-- print*,'XPSS =', XPSS, xps
732 C--- read(iread,*) xps
733 C--- if (xps.ge.0.) then
734  if (xps.le.0.) then
735  xps=0.
736  uwus=1.424
737  uo3us=0.344
738  else
739  if (idatm.ne.8) then
740  call pressure(uw,uo3,xps)
741  else
742  call pressure(uwus,uo3us,xps)
743  endif
744  endif
745 
746 c**********************************************************************c
747 c c
748 c xpp is the parameter to express the sensor altitude c
749 c c
750 c c
751 c xpp= 100 means that the sensor is a board a satellite c
752 c xpp= 0 means that the sensor is at the ground level c
753 c c
754 c c
755 c for aircraft simulations c
756 c 0< xpp <100 means you know the altitude of the sensor expressed c
757 c in kilometers units c
758 C this altitude is the ABSOLUTE target altitude (relative to the c
759 C SEA level. c
760 c c
761 c for aircraft simulations only, you have to give c
762 c puw,po3 (water vapor content,ozone content between the c
763 c aircraft and the surface) c
764 c taerp (the aerosol optical thickness at 550nm between the c
765 c aircraft and the surface) c
766 c if these data are not available, enter negative values for all c
767 c of them, puw,po3 will then be interpolated from the us62 standard c
768 C profile according to the values at ground level. Taerp will be c
769 c computed according to a 2km exponential profile for aerosol. c
770 c**********************************************************************c
771 c
772  xpp = xppp
773 C-- print*, 'XPPP = ', XPPP, xpp
774 C--- read(iread,*) xpp
775 C--- xpp=-xpp
776 C---Note because of changing xpp to absolute plane altitude (relative
777 C to the sea level) and in order to conform internal 6S
778 C computation scheme, we have to set xpp = xpp - xps
779  xpp = xpp - xps
780 C---Now xpp is relative to the "ELEVATED" ground target level --------
781  if (xpp.lt.0.0) then
782 c ground measurement option
783  palt=0.
784  pps=p(1)
785  idatmp=0
786  taer55p=0.
787  puw=0.
788  puoz=0.
789  else
790  if (xpp.gt.100.) then
791 c satellite case of equivalent
792  palt=1000.
793  pps=0.
794  taer55p=taer55
795  ftray=1.
796  idatmp=4
797  else
798 c "real" plane case
799 C--Temp Code (can remain here, because output not depend on puw & puo3):
800  puw = -2.5
801  puo3 = -0.03
802 C-- read(iread,*) puw,puo3
803 C--End of Temp Code
804  if (puw.lt.0.) then
805  call presplane(puw,puo3,xpp,ftray)
806  idatmp=2
807  if (idatm.eq.8) then
808  puwus=puw
809  puo3us=puo3
810  puw=puw*uw/uwus
811  puo3=puo3*uo3/uo3us
812  idatmp=8
813  endif
814  else
815  call presplane(puwus,puo3us,xpp,ftray)
816  idatmp=8
817  endif
818  if(ier) stop
819  palt=zpl(34)
820  pps=ppl(34)
821 C--Temp Code (can remain here to automatically distribute aerosol amounts
822 C below and above the airplane):
823  taer55p = -0.2
824 C--- read(iread,*) taer55p
825 C--End of Temp Code
826  if ((taer55p.lt.0.).or.((taer55-taer55p).lt.accu2)) then
827 c a scale heigh of 2km is assumed in case no value is given for taer55p
828  taer55p=taer55*(1.-exp(-palt/2.))
829  else
830 C compute effective scale heigh
831  sham=exp(-palt/4.)
832  sha=1.-(taer55p/taer55)
833  if (sha.ge.sham) then
834  taer55p=taer55*(1.-exp(-palt/4.))
835  else
836  sha=-palt/log(sha)
837  taer55p=taer55*(1.-exp(-palt/sha))
838  endif
839  endif
840  endif
841  endif
842 
843 c**********************************************************************c
844 c iwave input of the spectral conditions c
845 c -------------------------------- c
846 c c
847 c you choose to define your own spectral conditions: iwave=-1,0 or 1 c
848 c (three user s conditions ) c
849 c -2 enter wlinf, wlsup, the filter function will be equal to 1c
850 c over the whole band (as iwave=0) but step by step output c
851 c will be printed c
852 c -1 enter wl (monochr. cond, gaseous absorption is included) c
853 c c
854 c 0 enter wlinf, wlsup. the filter function will be equal to 1c
855 c over the whole band. c
856 c c
857 c 1 enter wlinf, wlsup and user's filter function s(lambda) c
858 c ( by step of 0.0025 micrometer). c
859 c c
860 c note: wl has to be in micrometer c
861 c**********************************************************************c
862  do 38 l=iinf,isup
863  s(l)=1.
864  38 continue
865 c
866 C--Temp code:
867  iwave = -2
868  wlinf = 0.30
869  wlsup = 2.90
870 C--End of Temp Code.
871  iinf=(wlinf-.25)/0.0025+1.5
872  isup=(wlsup-.25)/0.0025+1.5
873 
874 c**********************************************************************c
875 c here, we first compute an equivalent wavelenght which is the input c
876 c value for monochromatic conditions or the integrated value for a c
877 c filter functionr (vall equivwl) then, the atmospheric properties are c
878 c computed for that wavelength (call discom then call specinterp) c
879 c molecular optical thickness is computed too (call odrayl). lastly c
880 c the successive order of scattering code is called three times. c
881 c first for a sun at thetas with the scattering properties of aerosols c
882 c and molecules, second with a pure molecular atmosphere, then with thec
883 c actual atmosphere for a sun at thetav. the iso code allows us to c
884 c compute the scattering transmissions and the spherical albedo. all c
885 c these computations are performed for checking the accuracy of the c
886 c analytical expressions and in addition for computing the averaged c
887 c directional reflectances c
888 c**********************************************************************c
889  if(iwave.ne.-1) then
890  call equivwl(iinf,isup,step,
891  s wlmoy)
892  else
893  wlmoy=wl
894  endif
895 c write(6,*) "wlmoy: ",wlmoy
896  call discom (idatmp,iaer,xmus,xmuv,phi
897  a ,taer55,taer55p,palt,
898  a phirad,nt,mu,np,rm,gb,rp
899  s ,ftray,xlm1,xlm2)
900  if(iaer.ne.0) then
901  call specinterp(wlmoy,taer55,taer55p,
902  s tamoy,tamoyp,pizmoy,pizmoyp)
903  endif
904  call odrayl(wlmoy,
905  s trmoy)
906  trmoyp=trmoy*ftray
907  if (idatmp.eq.4) then
908  trmoyp=trmoy
909  tamoyp=tamoy
910  endif
911  if (idatmp.eq.0) then
912  trmoyp=0.
913  tamoyp=0.
914  endif
915 
916 c*********************************************************************c
917 c inhomo ground reflectance (type) c
918 c ------------------ c
919 c c
920 c you consider an homogeneous surface: c
921 c enter - inhomo=0 c
922 c you may consider directional surface effects c
923 c idirec=0 (no directional effect) c
924 c you have to specify the surface reflectance:c
925 c igroun (see note1) which is uniform and c
926 c lambertian c
927 c idirec=1 ( directional effect) c
928 c you have to specify the brdf of the surface c
929 c for the actual solar illumination you are c
930 c considering as well as the brdf for a sun c
931 c which would be at an angle thetav, in c
932 c addition you have to give the surface c
933 c albedo (spherical albedo). you can also c
934 c select one of the selected model from the c
935 c ibrdf value (see note2). 3 reflectances c
936 c are computed, robar,robarp and robard c
937 c c
938 c ****tree**** c
939 c c
940 c inhomo c
941 c / \ c
942 c / \ c
943 c / \ c
944 c / \ c
945 c ------- 0 ------- -----1 ----- c
946 c / / \ \ c
947 c idirec / \ \ c
948 c / \ / \ \ c
949 c / \ / \ \ c
950 c / \ igrou1 igrou2 rad c
951 c 0 1 roc roe f(r) c
952 c / \ c
953 c / \ c
954 c igroun ibrdf c
955 c (roc = roe) (roc) c
956 c (robar) c
957 c (robarp) c
958 c (robard) c
959 c c
960 c ground reflectance (spectral variation) c
961 c --------------------------------------- c
962 c note1: values of the reflectance selected by igroun,igrou1 or igrou2 c
963 c may correspond to the following cases, c
964 c 0 constant value of ro (or roc,or roe) whatever the wavelen c
965 c gth. you enter this constant value of ro (or roc or roe). c
966 c -1 you have to enter the value of ro (or roc,or roe) by step c
967 c of 0.0025 micron from wlinf to wlsup (if you have used thec
968 c satellite bands,see implicit values for these limits). c
969 c 1 mean spectral value of green vegetation c
970 c 2 mean spectral value of clear water c
971 c 3 mean spectral value of sand c
972 c 4 mean spectral value of lake water c
973 c**********************************************************************c
974 
975  fr=0.
976  rad=0.
977  do 1116 ik=iinf,isup
978  rocl(ik)=0.
979  roel(ik)=0.
980  1116 continue
981 
982 c**********************************************************************c
983 c uniform or non-uniform surface conditions c
984 c**********************************************************************c
985 C--- read(iread,*) inhomo
986  inhomo = 0
987 C--- if(inhomo) 30,30,31
988 C--- 30 read(iread,*) idirec
989  idirec = 0
990 
991 c**********************************************************************c
992 c uniform surface with lambertian conditions c
993 c**********************************************************************c
994 C--- 21 read(iread,*) igroun
995  igroun = 0
996  do 35 l=iinf,isup
997  rocl(l) = 0.
998  35 continue
999 c
1000  do 39 l=iinf,isup
1001  roel(l)=rocl(l)
1002  39 continue
1003 
1004 c**********************************************************************c
1005 
1006 
1007 c**********************************************************************c
1008 c print of initial conditions c
1009 c c
1010 c**********************************************************************c
1011 
1012 c ---- geometrical conditions ----
1013  write(iwr, 98)
1014  write(iwr, etiq1(igeom+1))
1015  if(igeom.eq.0) then
1016  write(iwr, 1401)
1017  write(iwr, 103)month,jday
1018  endif
1019  if(igeom.ne.0) write(iwr, 101)month,jday,tu,xlat,xlon
1020  write(iwr, 102)asol,phi0
1021  write(iwr, 1110)avis,phiv,adif,phi
1022 
1023 c --- atmospheric model ----
1024  write(iwr, 1119)
1025  if(idatm-7)226,227,228
1026  228 write(iwr, 1281)uw,uo3
1027  goto 219
1028  227 write(iwr, 1272)
1029  do 229 i=1,34
1030  write(iwr, 1271)z(i),p(i),t(i),wh(i),wo(i)
1031  229 continue
1032  goto 219
1033  226 write(iwr, 1261)atmid(idatm+1)
1034 
1035 c --- aerosols model (type) ----
1036  219 if (iaer.lt.4) then
1037  goto(230,231,232,233),iaer+1
1038  else
1039  if (iaer.ge.5.and.iaer.le.7) goto(234,235,236),iaer-4
1040  if (iaer.eq.4)write(iwr,133)(c(i),i=1,4)
1041  if (iaer.eq.8)then
1042  write(iwr,134)icp
1043  do i=1,icp
1044  write(iwr,135)x1(i),x2(i),cij(i)
1045  enddo
1046  endif
1047  if (iaer.eq.9)write(iwr,136)x1(1),x2(1),x3(1)
1048  if (iaer.eq.10)write(iwr,137)x1(1)
1049  if (iaer.eq.11)write(iwr, 131)' Sun Photometer'
1050  if (iaer.eq.12)write(iwr,138)file2(1:i2)
1051  if (iaerp.eq.1)write(iwr,139)file2(1:i2)
1052  goto 249
1053  endif
1054  234 write(iwr, 131)' Desertic'
1055  goto 249
1056  235 write(iwr, 131)' Smoke'
1057  goto 249
1058  236 write(iwr, 131)' Stratospheric'
1059  goto 249
1060  233 write(iwr, 131)' Urban'
1061  go to 249
1062  232 write(iwr, 131)' Maritime'
1063  goto 249
1064  231 write(iwr, 131)' Continental'
1065  goto 249
1066  230 write(iwr, 1301)
1067  249 continue
1068 
1069 c --- aerosol model (concentration) ----
1070  if(iaer.eq.0) write(iwr, 1401)
1071  if(iaer.eq.0) goto 1112
1072  if(abs(v).le.xacc) write(iwr, 140)taer55
1073  if(abs(v).gt.xacc) write(iwr, 141)v,taer55
1074 
1075 c --- spectral condition ----
1076  1112 CONTINUE
1077 c--- 1112 write(iwr, 148)
1078 c--- if(iwave.eq.-2) write(iwr, 1510) nsat(1),wlinf,wlsup
1079 c--- if(iwave.eq.-1) write(iwr, 149) wl
1080 c--- if(iwave.ge.0) write(iwr, 1510) nsat(iwave+1), wlinf,wlsup
1081 
1082 c --- ground reflectance (type and spectral variation) ----
1083  if(idirec.eq.0) then
1084  rocave=0.
1085  roeave=0.
1086  seb=0.
1087 
1088  do 264 i=iinf,isup
1089  sbor=s(i)
1090  if(i.eq.iinf.or.i.eq.isup) sbor=sbor*0.5
1091  wl=.25+(i-1)*step
1092 C---
1093 C--- call solirr(wl,
1094 C--- 1 swl)
1095  swl = 1.0
1096 C---
1097  swl=swl*dsol
1098  rocave=rocave+rocl(i)*sbor*swl*step
1099  roeave=roeave+roel(i)*sbor*swl*step
1100  seb=seb+sbor*swl*step
1101  264 continue
1102  rocave=rocave/seb
1103  roeave=roeave/seb
1104  isort=0
1105  ro=rocave
1106 
1107  if(inhomo.eq.0) goto 260
1108  write(iwr, 169)rad
1109  igroun=igrou1
1110  ro=rocave
1111  write(iwr, 170)
1112  goto 261
1113 
1114  262 igroun=igrou2
1115  ro=roeave
1116  write(iwr, 171)
1117  goto 261
1118 
1119  260 CONTINUE
1120 C--- 260 write(iwr, 168)
1121  261 if (igroun.gt.0)write(iwr, reflec(igroun+3))ro
1122  if (igroun.gt.0)goto 158
1123  if(igroun.eq.-1) write(iwr, reflec(1))ro
1124  if(igroun.eq.-1) goto 158
1125  if(iwave.eq.-1) write(iwr, reflec(2))ro
1126 C-- if(iwave.ne.-1) write(iwr, reflec(3))ro
1127  158 isort=isort+1
1128  if(inhomo.eq.0) goto 999
1129  if(isort.eq.2) goto 999
1130  goto 262
1131  else
1132  write(iwr, 168)
1133  endif
1134 
1135 c --- pressure at ground level (174) and altitude (175) ----
1136  999 write(iwr, 173)
1137  write(iwr, 174)p(1)
1138  write(iwr, 175)xps
1139 C--- if (xps.gt.0.) write(iwr, 176)uw,uo3
1140 
1141 c --- plane simulation output if selected ----
1142  if (palt.lt.1000.) then
1143 C--- write(iwr, 178)
1144  write(iwr, 179)pps
1145  write(iwr, 180)palt
1146 C--- write(iwr, 181)
1147 C--- write(iwr, 182)puo3
1148 C--- write(iwr, 183)puw
1149 C--- write(iwr, 184)taer55p
1150  endif
1151 
1152 c**********************************************************************c
1153 c c
1154 c c
1155 c start of computations c
1156 c c
1157 c c
1158 c c
1159 c**********************************************************************c
1160 
1161 c ---- spectral loop ----
1162 C--- if (iwave.eq.-2) write(iwr,1500)
1163  do 51 l=iinf,isup
1164  sbor=s(l)
1165  if(l.eq.iinf.or.l.eq.isup) sbor=sbor*0.5
1166  if(iwave.eq.-1) sbor=1.0/step
1167  roc=rocl(l)
1168  roe=roel(l)
1169  wl=.25+(l-1)*step
1170 c---
1171 C--- call solirr(wl,
1172 C--- s swl)
1173 C---
1174  call interp (iaer,idatmp,wl,taer55,taer55p,xmud,
1175  s romix,rorayl,roaero,phaa,phar,tsca,
1176  s tray,trayp,taer,taerp,dtott,utott,
1177  s astot,asray,asaer,
1178  s utotr,utota,dtotr,dtota)
1179 c
1180  if (iwave.eq.-2) then
1181 C-- write(iwr,1501) wl,tgtot,dtott,utott,astot,ratm2,swl,step,
1182 C-- s sbor,dsol,romeas2
1183 C--- write(iwr,1501) wl,tray,dtott,utott,astot,trayp,romix,rorayl,
1184 C--- s roaero,taer,taerp
1185 C
1186 C--Modified by B.-C. Gao
1187  jindex=l-iinf+1
1188  wltemp(jindex) = wl
1189  rotemp(jindex) = romix
1190  dttemp(jindex) = dtott*utott
1191  astemp(jindex) = astot
1192 C--- WRITE(6,*) WLTEMP(JINDEX),ROTEMP(JINDEX),DTTEMP(JINDEX),
1193 C--- & ASTEMP(JINDEX),JINDEX
1194 C---End of modifications ---
1195  endif
1196 
1197  51 continue
1198 C
1199 C--Modified by B.-C. Gao ---
1200 C
1201  nelem = isup-iinf+1
1202 C
1203 C-- DO L = 1, NELEM
1204 C-- WRITE(6,*) WLTEMP(L),ROTEMP(L),DTTEMP(L),
1205 C-- & ASTEMP(L),L
1206 C-- END DO
1207 
1208  CALL cubspln(nelem,wltemp,rotemp,wavobs,rotot)
1209  CALL cubspln(nelem,wltemp,dttemp,wavobs,ttot)
1210  CALL cubspln(nelem,wltemp,astemp,wavobs,stot)
1211  WRITE(*,*) 'I,WAVOBS(I), ROTOT(I), TTOT(I), STOT(I)'
1212  DO 122 i=1,128
1213  122 WRITE(*,*) i,wavobs(i), rotot(i), ttot(i), stot(i)
1214 C-- DO 123 I=1,ISUP,10
1215 C-- 123 WRITE(*,*)'I=',I,' TTOT(I)=',TTOT(I)
1216 C-- DO 124 I=1,ISUP,10
1217 C-- 124 WRITE(*,*)'I=',I,' STOT(I)=',STOT(I)
1218 ******End of addition
1219 
1220  WRITE(*,9257)
1221  9257 format(79(1h*),/)
1222 
1223  return
1224 
1225 c**********************************************************************c
1226 c c
1227 c output editing formats c
1228 c c
1229 c c
1230 c**********************************************************************c
1231  98 format(///,1h*,30(1h*),16h 6s version 4.1 ,30(1h*),t79
1232  s ,1h*,/,1h*,t79,1h*,/,
1233  s 1h*,22x,34h geometrical conditions identity ,t79,1h*,/,
1234  s 1h*,22x,34h ------------------------------- ,t79,1h*)
1235  101 format(1h*,15x,7h month:,i3,7h day : ,i3,
1236  s 16h universal time:,f6.2,
1237  s 10h(hh.dd) ,t79,1h*,/,
1238  s 1h*, 15x,10hlatitude: ,f7.2,5h deg ,6x,
1239  s 12h longitude: ,f7.2,5h deg ,t79,1h*)
1240  102 format(1h*,2x,22h solar zenith angle: ,f6.2,5h deg ,
1241  s 29h solar azimuthal angle: ,f6.2,5h deg ,t79,1h*)
1242  103 format(1h*,2x,7h month:,i3,7h day : ,i3,t79,1h*)
1243  1110 format(1h*,2x,22h view zenith angle: ,f6.2,5h deg ,
1244  s 29h view azimuthal angle: ,f6.2,5h deg ,
1245  s t79,1h*,/,
1246  s 1h*,2x,22h scattering angle: ,f6.2,5h deg ,
1247  s 29h azimuthal angle difference: ,f6.2,5h deg ,
1248  s t79,1h*)
1249  1119 format(1h*,t79,1h*,/,
1250  s 1h*,22x,31h atmospheric model description ,t79,1h*,/,
1251  s 1h*,22x,31h ----------------------------- ,t79,1h*)
1252  1261 format(1h*,10x,30h atmospheric model identity : ,t79,1h*,/,
1253  s 1h*,15x,a51,t79,1h*)
1254  1272 format(1h*,30h atmospheric model identity : ,t79,1h*,/,
1255  s 1h*,12x,33h user defined atmospheric model ,t79,1h*,/,
1256  s 1h*,12x,11h*altitude ,11h*pressure ,
1257  s 11h*temp. ,11h*h2o dens. ,11h*o3 dens. ,t79,1h*)
1258  1271 format(1h*,12x,5e11.4,t79,1h*)
1259  1281 format(1h*,10x,31h atmospheric model identity : ,t79,1h*,
1260  s /,1h*,12x,35h user defined water content : uh2o=,f6.3,
1261  s 7h g/cm2 ,t79,1h*,
1262  s /,1h*,12x,35h user defined ozone content : uo3 =,f6.3,
1263  s 7h cm-atm,t79,1h*)
1264  1301 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1265  s 1h*,15x,24h no aerosols computed ,t79,1h*)
1266  131 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1267  s 1h*,15x,a15,15h aerosols model,t79,1h*)
1268  133 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1269  s 1h*,15x,29h user defined aerosols model ,t79,1h*,/,
1270  s 1h*,26x,f6.3,15h % of dust-like,t79,1h*,/,
1271  s 1h*,26x,f6.3,19h % of water-soluble,t79,1h*,/,
1272  s 1h*,26x,f6.3,13h % of oceanic,t79,1h*,/,
1273  s 1h*,26x,f6.3,10h % of soot,t79,1h*)
1274  134 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1275  s 1h*,15x,29h user defined aerosols model ,t79,1h*,/,
1276  s 1h*,15x,6husing ,i1,32h log-normal size-distribution(s),t79,
1277  s 1h*,/,1h*,15x,42hmean radius stand. dev. percent. dencity,
1278  s t79,1h*)
1279  135 format(1h*,t41,f6.4,t55,f5.3,t69,e8.3,t79,1h*)
1280  136 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1281  s 1h*,15x,29h user defined aerosols model ,t79,1h*,/,
1282  s 1h*,15x,40husing a modified gamma size-distribution,t79,1h*,/,
1283  s 1h*,19x,33halpha b gamma,t79,1h*,/,
1284  s 1h*,t20,f6.3,t31,f6.3,t47,f6.3,t79,1h*)
1285  137 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1286  s 1h*,15x,29h user defined aerosols model ,t79,1h*,/,
1287  s 1h*,15x,47husing a power law size-distribution with alpha=,
1288  s f3.1,t79,1h*)
1289  138 format(1h*,10x,25h aerosols type identity :,t79,1h*,/,
1290  s 1h*,15x,29h user defined aerosols model ,t79,1h*,/,
1291  s 1h*,15x,25husing data from the file:,t79,1h*,/,
1292  s 1h*,t25,a30,t79,1h*)
1293  139 format(1h*,15x,29h results saved into the file:,t79,1h*,/,
1294  s 1h*,t25,a30,t79,1h*)
1295  140 format(1h*,10x,29h optical condition identity :,t79,1h*,/,
1296  s 1h*,15x,31h user def. opt. thick. at 550nm :,f7.4,
1297  s t79,1h*,/,1h*,t79,1h*)
1298  141 format(1h*,10x,29h optical condition identity :,t79,1h*,/,
1299  s 1h*,15x,13h visibility :,f6.2,4h km ,
1300  s 20h opt. thick. 550nm :,f7.4,t79,1h*,/,
1301  s 1h*,t79,1h*)
1302  148 format(1h*,22x,21h spectral condition ,t79,1h*,/,1h*,
1303  s 22x,21h ------------------ ,t79,1h*)
1304  149 format(1h*,12x,34h monochromatic calculation at wl :,
1305  s f6.3,8h micron ,t79,1h*)
1306  1510 format(1h*,10x,a17,t79,1h*,/,
1307  s 1h*,15x,26hvalue of filter function :,t79,1h*,/,1h*,
1308  s 15x,8h wl inf=,f6.3,4h mic,2x,8h wl sup=,f6.3,4h mic,t79,1h*)
1309  168 format(1h*,t79,1h*,/,1h*,22x,14h target type ,t79,1h*,/,1h*,
1310  s 22x,14h ----------- ,t79,1h*,/,1h*,
1311  s 10x,20h homogeneous ground ,t79,1h*)
1312  169 format(1h*,t79,1h*,/,1h*,22x,14h target type ,t79,1h*,/,1h*,
1313  s 22x,14h ----------- ,t79,1h*,/,1h*,
1314  s 10x,41h inhomogeneous ground , radius of target ,f6.3,
1315  s 5h km ,t79,1h*)
1316  170 format(1h*,15x,22h target reflectance : ,t79,1h*)
1317  171 format(1h*,15x,29h environmental reflectance : ,t79,1h*)
1318  172 format(1h*,t79,1h*,/,79(1h*),///)
1319  173 format(1h*,t79,1h*,/,
1320  s 1h*,22x,30h target elevation description ,t79,1h*,/,
1321  s 1h*,22x,30h ---------------------------- ,t79,1h*)
1322  174 format(1h*,10x,22h ground pressure [mb] ,1x,f7.2,1x,t79,1h*)
1323  175 format(1h*,10x,22h ground altitude [km] ,f6.3,1x,t79,1h*)
1324  176 format(1h*,15x,34h gaseous content at target level: ,t79,1h*,
1325  s /,1h*,15x,6h uh2o=,f6.3,7h g/cm2 ,
1326  s 5x,6h uo3=,f6.3,7h cm-atm,t79,1h*)
1327 
1328 c pressure at ground level (174) and altitude (175)
1329  178 format(1h*,t79,1h*,/,
1330  s 1h*,22x,30h plane simulation description ,t79,1h*,/,
1331  s 1h*,22x,30h ---------------------------- ,t79,1h*)
1332  179 format(1h*,10x,31h plane pressure [mb] ,f7.2,1x,t79,1h*)
1333  180 format(1h*,10x,31h plane altitude absolute [km] ,f6.3,1x,t79,1h*)
1334  181 format(1h*,15x,37h atmosphere under plane description: ,t79,1h*)
1335  182 format(1h*,15x,26h ozone content ,f6.3,1x,t79,1h*)
1336  183 format(1h*,15x,26h h2o content ,f6.3,1x,t79,1h*)
1337  184 format(1h*,15x,26haerosol opt. thick. 550nm ,f6.3,1x,t79,1h*)
1338 
1339  1401 format(1h*,t79,1h*)
1340  1500 format(1h*,1x,42hwave total total total total atm. ,
1341  s 33hswl step sbor dsol toar ,t79,1h*,/,
1342  s 1h*,1x,42h gas scat scat spheri intr ,t79,1h*,/,
1343  s 1h*,1x,42h trans down up albedo refl ,t79,1h*)
1344 C--1501 format(1h*,6(F6.4,1X),F6.1,1X,4(F6.4,1X),t79,1h*)
1345  1501 format(1x,6(f6.4,1x),f6.4,1x,4(f6.4,1x),t79,1x)
1346 
1347  end
1348 
1349  subroutine aeroso (iaer,co,xmud,wldis,FILE)
1350 
1351  double precision cij(4),vi(4),nis,sumni,ni(4)
1352  real co(4),dd(4,10),ci(4),ex(4,10),sc(4,10),asy(4,10)
1353  real pha(5,10,83),sca(10),wldis(10)
1354  real ex2(1,10),sc2(1,10),asy2(1,10)
1355  real ex3(1,10),sc3(1,10),asy3(1,10)
1356  real ex4(1,10),sc4(1,10),asy4(1,10)
1357  real xmud,ext,ome,gasym,phase,ph,phasel,cgaus,pdgs
1358  real coef,sigm,pi
1359  integer i,j,k,l,j1,j2,iaer,icp
1360  character FILE*80
1361 c sra basic components for aerosol model, extinction coefficients are
1362 c in km-1.
1363 c dust-like = 1
1364 c water-soluble = 2
1365 c oceanique = 3
1366 c soot = 4
1367 
1368  data vi /113.983516,113.983516d-06,5.1444150196,
1369  a 59.77353425d-06/
1370  data ni /54.734,1.86855d+06,276.05,1.80582d+06/
1371 
1372 c i: 1=dust-like 2=water-soluble 3=oceanic 4=soot
1373  data ((ex(i,j),sc(i,j),j=1,10),i=1,1) /
1374  a 0.1796674e-01,0.1126647e-01,0.1815135e-01,0.1168918e-01,
1375  a 0.1820247e-01,0.1180978e-01,0.1827016e-01,0.1196792e-01,
1376  a 0.1842182e-01,0.1232056e-01,0.1853081e-01,0.1256952e-01,
1377  a 0.1881427e-01,0.1319347e-01,0.1974608e-01,0.1520712e-01,
1378  a 0.1910712e-01,0.1531952e-01,0.1876025e-01,0.1546761e-01/
1379  data ((ex(i,j),sc(i,j),j=1,10),i=2,2) /
1380  a 0.7653460e-06,0.7377123e-06,0.6158538e-06,0.5939413e-06,
1381  a 0.5793444e-06,0.5587120e-06,0.5351736e-06,0.5125148e-06,
1382  a 0.4480091e-06,0.4289210e-06,0.3971033e-06,0.3772760e-06,
1383  a 0.2900993e-06,0.2648252e-06,0.1161433e-06,0.9331806e-07,
1384  a 0.3975192e-07,0.3345499e-07,0.1338443e-07,0.1201109e-07/
1385  data ((ex(i,j),sc(i,j),j=1,10),i=3,3) /
1386  a 0.3499458e-02,0.3499455e-02,0.3574996e-02,0.3574993e-02,
1387  a 0.3596592e-02,0.3596591e-02,0.3622467e-02,0.3622465e-02,
1388  a 0.3676341e-02,0.3676338e-02,0.3708866e-02,0.3708858e-02,
1389  a 0.3770822e-02,0.3770696e-02,0.3692255e-02,0.3677038e-02,
1390  a 0.3267943e-02,0.3233194e-02,0.2801670e-02,0.2728013e-02/
1391  data ((ex(i,j),sc(i,j),j=1,10),i=4,4) /
1392  a 0.8609083e-06,0.2299196e-06,0.6590103e-06,0.1519321e-06,
1393  a 0.6145787e-06,0.1350890e-06,0.5537643e-06,0.1155423e-06,
1394  a 0.4503008e-06,0.8200095e-07,0.3966041e-06,0.6469735e-07,
1395  a 0.2965532e-06,0.3610638e-07,0.1493927e-06,0.6227224e-08,
1396  a 0.1017134e-06,0.1779378e-08,0.6065031e-07,0.3050002e-09/
1397 
1398  data ((ex2(i,j),sc2(i,j),j=1,10),i=1,1) /
1399  a 0.4383631e+02,0.4028625e+02,0.4212415e+02,0.3904473e+02,
1400  a 0.4157425e+02,0.3861470e+02,0.4085399e+02,0.3803645e+02,
1401  a 0.3914040e+02,0.3661054e+02,0.3789763e+02,0.3554456e+02,
1402  a 0.3467506e+02,0.3269951e+02,0.2459000e+02,0.2341019e+02,
1403  a 0.1796726e+02,0.1715375e+02,0.1057569e+02,0.1009731e+02/
1404 
1405  data ((ex3(i,j),sc3(i,j),j=1,10),i=1,1) /
1406  a 0.9539786e+05,0.9297790e+05,0.7530360e+05,0.7339717e+05,
1407  a 0.7021064e+05,0.6842549e+05,0.6421828e+05,0.6257180e+05,
1408  a 0.5243056e+05,0.5104987e+05,0.4557768e+05,0.4434877e+05,
1409  a 0.3193777e+05,0.3100621e+05,0.9637680e+04,0.9202678e+04,
1410  a 0.3610691e+04,0.3344476e+04,0.8105614e+03,0.6641915e+03/
1411 
1412  data ((ex4(i,j),sc4(i,j),j=1,10),i=1,1) /
1413  a .5427304e+08, .5427304e+08, .6198144e+08, .6198144e+08,
1414  a .6302432e+08, .6302432e+08, .6348947e+08, .6348947e+08,
1415  a .6146760e+08, .6146760e+08, .5817972e+08, .5817972e+08,
1416  a .4668909e+08, .4668909e+08, .1519062e+08, .1519062e+08,
1417  a .5133055e+07, .5133055e+07, .8998594e+06, .8998594e+06/
1418 
1419  data ((asy(i,j),j=1,10),i=1,4) /
1420  a 0.896,0.885,0.880,0.877,0.867,0.860,0.845,0.836,0.905,0.871,
1421  a 0.642,0.633,0.631,0.628,0.621,0.616,0.610,0.572,0.562,0.495,
1422  a 0.795,0.790,0.788,0.781,0.783,0.782,0.778,0.783,0.797,0.750,
1423  a 0.397,0.359,0.348,0.337,0.311,0.294,0.253,0.154,0.103,0.055/
1424 
1425  data ((asy2(i,j),j=1,10),i=1,1)/
1426  a 0.718,0.712,0.710,0.708,0.704,0.702,0.696,0.680,0.668,0.649/
1427 
1428  data ((asy3(i,j),j=1,10),i=1,1)/
1429  a 0.704,0.690,0.686,0.680,0.667,0.659,0.637,0.541,0.437,0.241/
1430 
1431  data ((asy4(i,j),j=1,10),i=1,1)/
1432  a .705, .744, .751, .757, .762, .759, .737, .586, .372, .139/
1433 
1434  common /sixs_aer/ ext(10),ome(10),gasym(10),phase(10)
1435  common /sixs_aerbas/ ph(10,83)
1436  common /sixs_sos/phasel(10,83),cgaus(83),pdgs(83)
1437 c
1438 c optical properties of aerosol model computed from sra basic comp
1439  pi=4.*atan(1.)
1440  do 1 l=1,10
1441  ext(l)=0.
1442  sca(l)=0.
1443  if(l.eq.4.and.iaer.eq.0) ext(l)=1.
1444  ome(l)=0.
1445  gasym(l)=0.
1446  phase(l)=0.
1447  do 1 k=1,83
1448  phasel(l,k)=0.
1449  1 continue
1450 
1451  do 2 j=1,4
1452  ci(j)=co(j)
1453  2 continue
1454 
1455  if(iaer.eq.0) return
1456 
1457  do 7 k=1,82
1458  if((xmud.ge.cgaus(k)).and.(xmud.lt.cgaus(k+1))) go to 8
1459  7 continue
1460  return
1461  8 j1=k
1462  j2=j1+1
1463  coef=-(xmud-cgaus(j1))/(cgaus(j2)-cgaus(j1))
1464 
1465  if (iaer.eq.12) then
1466  open(10,file=file)
1467  read(10,*)
1468  do l=1,10
1469  read(10,'(8x,4(3x,f6.4,3x))')ext(l),sca(l),ome(l),gasym(l)
1470  enddo
1471  read(10,'(///)')
1472  do k=1,83
1473  read(10,'(8x,10(1x,e10.4))')(phasel(l,k),l=1,10)
1474  enddo
1475  close(10)
1476  do l=1,10
1477  phase(l)=phasel(l,j1)+coef*(phasel(l,j1)-phasel(l,j2))
1478  enddo
1479  return
1480  endif
1481 c
1482  if (iaer.eq.5) then
1483  do k=1,10
1484  asy(1,k)=asy2(iaer-4,k)
1485  ex(1,k)=ex2(iaer-4,k)
1486  sc(1,k)=sc2(iaer-4,k)
1487  enddo
1488  endif
1489 c
1490  if (iaer.eq.6) then
1491  do k=1,10
1492  asy(1,k)=asy3(iaer-5,k)
1493  ex(1,k)=ex3(iaer-5,k)
1494  sc(1,k)=sc3(iaer-5,k)
1495  enddo
1496  endif
1497 c
1498  if (iaer.eq.7) then
1499  do k=1,10
1500  asy(1,k)=asy4(iaer-6,k)
1501  ex(1,k)=ex4(iaer-6,k)
1502  sc(1,k)=sc4(iaer-6,k)
1503  enddo
1504  endif
1505 c
1506 c
1507  if (iaer.ge.5.and.iaer.le.11) then
1508 c calling a special aerosol model
1509 C (background desert model...)
1510  if (iaer.eq.5) call bdm
1511 C (biomass burning model...)
1512  if (iaer.eq.6) call bbm
1513 C (stratospherique aerosol model...)
1514  if (iaer.eq.7) call stm
1515 C (user defined model from size distribution)
1516  if (iaer.ge.8.and.iaer.le.11) call mie(iaer,wldis,ex,sc,asy)
1517 
1518  do l=1,10
1519  dd(1,l)=ph(l,j1)+coef*(ph(l,j1)-ph(l,j2))
1520  do k=1,83
1521  pha(1,l,k)=ph(l,k)
1522  enddo
1523  enddo
1524  icp=1
1525  cij(1)=1.00
1526 c for normalization of the extinction coefficient
1527  nis=1.d+00/ex(1,4)
1528  else
1529 c calling each sra components
1530  icp=4
1531 c -dust
1532  call dust
1533  do l=1,10
1534  dd(1,l)=ph(l,j1)+coef*(ph(l,j1)-ph(l,j2))
1535  do k=1,83
1536  pha(1,l,k)=ph(l,k)
1537  enddo
1538  enddo
1539 c -water soluble
1540  call wate
1541  do l=1,10
1542  dd(2,l)=ph(l,j1)+coef*(ph(l,j1)-ph(l,j2))
1543  do k=1,83
1544  pha(2,l,k)=ph(l,k)
1545  enddo
1546  enddo
1547 c -oceanic type
1548  call ocea
1549  do l=1,10
1550  dd(3,l)=ph(l,j1)+coef*(ph(l,j1)-ph(l,j2))
1551  do k=1,83
1552  pha(3,l,k)=ph(l,k)
1553  enddo
1554  enddo
1555 c - soot
1556  call soot
1557  do l=1,10
1558  dd(4,l)=ph(l,j1)+coef*(ph(l,j1)-ph(l,j2))
1559  do k=1,83
1560  pha(4,l,k)=ph(l,k)
1561  enddo
1562  enddo
1563 c summ of the ci/vi calculation
1564  sumni=0.
1565  sigm=0.
1566  do 3 i=1,4
1567  3 sigm=sigm+ci(i)/vi(i)
1568 
1569 c cij coefficients calculation
1570  do 4 j=1,4
1571  cij(j)=(ci(j)/vi(j)/sigm)
1572  4 sumni=sumni+cij(j)/ni(j)
1573 
1574 c nis=1/Kext(550)
1575  nis=1.d+00/sumni
1576  endif
1577 
1578 c mixing parameters calculation
1579  do 5 l=1,10
1580  do 6 j=1,icp
1581  ext(l)=ex(j,l)*cij(j)+ext(l)
1582  sca(l)=sc(j,l)*cij(j)+sca(l)
1583  gasym(l)=sc(j,l)*cij(j)*asy(j,l)+gasym(l)
1584  phase(l)=sc(j,l)*cij(j)*dd(j,l)+phase(l)
1585  do 77 k=1,83
1586  phasel(l,k)=sc(j,l)*cij(j)*pha(j,l,k)+phasel(l,k)
1587  77 continue
1588  6 continue
1589  ome(l)=sca(l)/ext(l)
1590  gasym(l)=gasym(l)/sca(l)
1591  phase(l)=phase(l)/sca(l)
1592  do 78 k=1,83
1593  phasel(l,k)=phasel(l,k)/sca(l)
1594  78 continue
1595  ext(l)=ext(l)*nis
1596  sca(l)=sca(l)*nis
1597  5 continue
1598  if (iaer.ge.8.and.iaer.le.11) then
1599  open(10,file=file)
1600  write(10,'(3x,A5,1x,5(1x,A10,1x),1x,A10)')'Wlgth',
1601  s'Nor_Ext_Co','Nor_Sca_Co','Sg_Sca_Alb',
1602  s'Asymm_Para','Extinct_Co','Scatter_Co'
1603  do 79 l=1,10
1604  write(10,'(2x,f6.4,4(3x,f6.4,3x),2(2x,e10.4))')
1605  s wldis(l),ext(l),sca(l),ome(l),gasym(l),ext(l)/nis,sca(l)/nis
1606  79 continue
1607  write(10,'(//,T20,A16,/,3x,A4,1x,10(3x,f6.4,2x))')
1608  s ' Phase Function ','TETA',(wldis(l),l=1,10)
1609  do 76 k=1,83
1610  write(10,'(2x,f6.2,10(1x,e10.4))')180.*acos(cgaus(k))/pi,
1611  s (phasel(l,k),l=1,10)
1612  76 continue
1613  close(10)
1614  endif
1615  return
1616  end
1617  subroutine msrm
1618 c
1619 c MultiSpectral Reflectance Model 93 A.Kuusk 24.03.1993
1620 c
1621  implicit double precision (a-h, o-z)
1622  save /count/, /soildata/, /aaa/, /ggg/, /ladak/
1623 c
1624  dimension u1(10), u2(10), a1(10), a2(10)
1625  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
1626 c
1627  double precision nnl, kk
1628  common /leafin/ nnl, vai, kk
1629  common /leafout/ refl, tran
1630 c
1631  double precision ke, kab, kw
1632  dimension refr(200), ke(200), kab(200), kw(200)
1633  common /dat/ refr, ke, kab, kw
1634 c
1635  dimension phis1(200), phis2(200), phis3(200), phis4(200)
1636  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2, rsl3,
1637  & rsl4, th2, rsl, rsoil, rr1soil, rrsoil
1638 c
1639  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
1640  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
1641  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
1642  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
1643  & alph, salph, alpp, difmy, difsig
1644  common /cfresn/ rn, rk
1645  common /ladak/ ee, thm, sthm, cthm
1646  common /msrmdata/ th10, rncoef, cab, cw, bq
1647 c
1648  data pi12/1.570796326794895d0/, pi/3.141592653589793d0/
1649  data eps4/.1d-3/
1650 c
1651 * print *, 'msrm'
1652 c
1653  sth10 = sin(th10)
1654  cth10 = cos(th10)
1655 c
1656  sp = sin(phi)
1657  cp = cos(phi)
1658  th1 = th10
1659  sth1 = sth10
1660  cth1 = cth10
1661  sth = sin(th)
1662  cth = cos(th)
1663  rrls = rrl
1664 c
1665  call biz
1666 c
1667  rrl = refl
1668  rtp = rrl + ttl
1669 c
1670  call difr92
1671 c
1672 10 continue
1673 c
1674  rrl = rrls
1675  bq = bi + bd
1676 c
1677  return
1678  end
1679 *
1680 ******************************************************************
1681 *
1682  subroutine akd
1683 c bdz A.Kuusk 4.03.1988
1684 c
1685  implicit double precision (a-h, o-z)
1686  save /count/, /aaa/, /ggg/
1687 c
1688  dimension tt3(10), stt3(10), ctt3(10), tt2(10), stt2(10), ctt2(10)
1689 c
1690  dimension u1(10), u2(10), a1(10), a2(10)
1691  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
1692 c
1693  double precision nnl, kk
1694  common /leafin/ nnl, vai, kk
1695  common /leafout/ refl, tran
1696 c
1697  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
1698  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
1699  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
1700  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
1701  & alph, salph, alpp, difmy, difsig
1702 c
1703  data pi/3.141592653589793d0/, pi1/1.5707963268d0/, eps/.005d0/
1704 c
1705 * print *, 'akd'
1706  bqint = 0.d0
1707  if (th .gt. eps) goto 4
1708  phi = 0.d0
1709  sp = 0.d0
1710  cp = 1.d0
1711 c
1712  do 10 i2 = 1, n2
1713  th1 = (1.d0 - u2(i2))*pi1
1714  sth1 = sin(th1)
1715  cth1 = cos(th1)
1716  rrls = rrl
1717 c
1718  call biz
1719 c
1720  rrl = refl
1721  rtp = rrl + ttl
1722 c
1723  call difr92
1724 c
1725  rrl = rrls
1726  bqint = bqint + a2(i2)*(bi + bd)*sth1*cth1
1727 10 continue
1728 c
1729  bqint = bqint*pi
1730  goto 1
1731 c
1732 4 continue
1733  do 14 i = 1, n1
1734  thi = u1(i)*th
1735  tt3(i) = thi
1736  stt3(i) = sin(thi)
1737  ctt3(i) = cos(thi)
1738 14 continue
1739 c
1740  do 15 i = 1, n2
1741  thi = u2(i)*(th - pi1) + pi1
1742  tt2(i) = thi
1743  stt2(i) = sin(thi)
1744  ctt2(i) = cos(thi)
1745 15 continue
1746 c
1747  do 11 j = 1, n1
1748  phi = (1.d0 - u1(j))*pi
1749  sp = sin(phi)
1750  cp = cos(phi)
1751  bd1 = 0.d0
1752  bd2 = 0.d0
1753  do 12 i1 = 1, n1
1754  th1 = tt3(i1)
1755  sth1 = stt3(i1)
1756  cth1 = ctt3(i1)
1757 c
1758  rrls = rrl
1759 c
1760  call biz
1761 c
1762  rrl = refl
1763  rtp = rrl + ttl
1764 c
1765  call difr92
1766 c
1767  rrl = rrls
1768 c
1769  bd1 = bd1 + a1(i1)*(bi + bd)*sth1*cth1
1770 12 continue
1771 c
1772  do 13 i2 = 1, n2
1773  th1 = tt2(i2)
1774  sth1 = stt2(i2)
1775  cth1 = ctt2(i2)
1776 c
1777  rrls = rrl
1778 c
1779  call biz
1780 c
1781  rrl = refl
1782  rtp = rrl + ttl
1783 c
1784  call difr92
1785 c
1786  rrl = rrls
1787 c
1788  bd2 = bd2 + a2(i2)*(bi + bd)*sth1*cth1
1789 13 continue
1790 c
1791  bqint = bqint + ((pi1 - th)*bd2 + th*bd1)*a1(j)
1792 11 continue
1793 c
1794  bqint = bqint + bqint
1795 c
1796 1 return
1797  end
1798 *
1799 ******************************************************************
1800 *
1801  subroutine biz
1802 c canopy reflectance of single scattering for direct radiation
1803 c A. Kuusk 6.02.1992
1804 c
1805  implicit double precision (a-h, o-z)
1806  double precision integr
1807  save /count/, /soildata/, /aaa/, /ggg/, /ladak/
1808 c
1809 * dimension gj(2), g1j(2), grj(2), gtj(2), gfj(2)
1810 c
1811  dimension u1(10), u2(10), a1(10), a2(10)
1812  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
1813 c
1814  dimension phis1(200), phis2(200), phis3(200), phis4(200)
1815  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
1816  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
1817 c
1818  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
1819  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
1820  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
1821  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
1822  & alph, salph, alpp, difmy, difsig
1823  common /ladak/ ee, thm, sthm, cthm
1824 c
1825  data pi/3.14159265358979d0/, eps/.1d-4/, eps3/.01d0/
1826 c
1827  integr(xx) = (1.d0 - exp(-xx))/xx
1828 * print *, 'biz in'
1829  ths = th
1830  sths = sth
1831  cths = cth
1832  th1s = th1
1833  sth1s = sth1
1834  cth1s = cth1
1835 * thms = thm
1836 c
1837  call soil
1838 c
1839  if (ul .gt. eps) goto 2
1840  bi = rsoil
1841  goto 1
1842 c
1843 2 continue
1844  if (th1 .lt. th) goto 12
1845  t11 = th1
1846  st = sth
1847  st1 = sth1
1848  ct = cth
1849  ct1 = cth1
1850  t10 = th
1851  jj = 0
1852  goto 7
1853 c
1854 12 t10 = th1
1855  st = sth1
1856  st1 = sth
1857  ct = cth1
1858  ct1 = cth
1859  t11 = th
1860  jj = 1
1861 c
1862 7 continue
1863  ctt1 = ct*ct1
1864  stt1 = st*st1
1865  calph = stt1*cp + ctt1
1866  catmp = calph
1867  alph = acos(catmp)
1868  alp2 = alph*.5d0
1869 * if (lf .ne. 2) then
1870 * if( jg .gt. 2) then
1871 * print *, ' *** biz3: jg > 2 ***'
1872 * stop
1873 * endif
1874  e1 = st*ct1
1875  e2 = ct*st1
1876  s2 = e1*cp + e2
1877  s3 = e1*sp
1878  ctg = 1.d30
1879  ctg1 = 1.d30
1880  if (st .ne. 0.d0) ctg = ct/st
1881  if (st1 .ne. 0.d0) ctg1 = ct1/st1
1882  salph = sin(alph)
1883  alpp = pi - alph
1884  salp2 = sin(alp2)
1885  calp2 = cos(alp2)
1886 c
1887  call gmf(gf)
1888 c
1889  if (ee .le. eps3) goto 95
1890  y4 = abs(cth + cth1)*.5d0/calp2
1891  if (y4.lt.1.d0) thp = acos(y4)
1892 c
1893 95 call glak(glthp, thp)
1894 c
1895  x2 = glthp*.125d0
1896  gf = gf*x2
1897 c
1898  call gmd92
1899 c
1900  gammd = gr*rrl + gt*ttl
1901 c
1902  t11 = th1
1903  st = sth
1904  st1 = sth1
1905  ct = cth
1906  ct1 = cth1
1907  t10 = th
1908  if (jj .eq. 1) then
1909  x = g1
1910  g1 = g
1911  g = x
1912  endif
1913 c
1914 * print *, 'biz:2'
1915  gg = g*g1
1916  g = g*clmp
1917  g1 = g1*clmp1
1918  gg1 = g*ct1 + g1*ct
1919  sct = sqrt(ctt1)
1920  alpd = alp2/sl
1921  bam = alpd*sct/ul
1922 c
1923  xx1 = 0.d0
1924  if (ctt1 .gt. eps) then
1925  gma = alpd/sct
1926  ulg = gg1/ctt1*ul
1927  ulg1 = ulg*.5d0
1928  xx1 = ulg + gma
1929  endif
1930  if ((xx1 .gt. 30.d0) .or. (ctt1 .le. eps)) then
1931  easte = 0.d0
1932  easte2 = 0.d0
1933  easte4 = 0.d0
1934  bs1 = 0.d0
1935  else
1936  easte = exp(-ulg)
1937  easte2 = exp(-ulg1 - gma)
1938  easte4 = exp(-ulg - gma)
1939  bs1 = (easte + easte2 - easte4)*rsoil
1940  endif
1941 c
1942  xx1 = (1.d0 - easte)/gg1
1943  xx2 = (1.d0 - easte2)/(gg1*.5d0 + bam) -
1944  & (1.d0 - easte4)/(gg1 + bam)
1945  bc1d = xx1*gammd
1946  bc1hs = xx2*(gammd + gf)
1947  bcsp = xx1*gf
1948  bc1 = bc1d + bcsp + bc1hs
1949  bi = bc1 + bs1
1950 c
1951 1 continue
1952  th = ths
1953  sth = sths
1954  cth = cths
1955  th1 = th1s
1956  sth1 = sth1s
1957  cth1s = cth1
1958 * thm = thms
1959 c
1960  return
1961  end
1962 *
1963 ******************************************************************
1964 *
1965  subroutine difr92
1966 c diffuse fluxes according to SAIL for an elliptical LAD
1967 c A. Kuusk 16.06.1992
1968 c
1969  implicit double precision (a-h, o-z)
1970  double precision ks, ko, m, m11, m12, m21, m22, integr
1971  save /soildata/, /aaa/, /ggg/, /ladak/
1972 c
1973  dimension phis1(200), phis2(200), phis3(200), phis4(200)
1974  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
1975  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
1976 c
1977  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
1978  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
1979  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
1980  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
1981  & alph, salph, alpp, difmy, difsig
1982  common /ladak/ ee, thm, sthm, cthm
1983 c
1984  integr(x) = (1.d0 - exp(-x))/x
1985 * print *, 'difr92'
1986 c
1987  tsun = th1
1988  tview = th
1989  tants = sth1/cth1
1990  tanto = sth/cth
1991  rtp = (rrl + ttl)/2.d0
1992 c
1993  ks = g1*ul/cth1
1994  ko = g*ul/cth
1995  gg = (1.289d0*difmy - 1.816d0*difsig)*(cthm**2 -
1996  & .33333333333d0) + .31823d0
1997  bf = (rrl - ttl)/2.d0*ul*gg
1998  att = (1.d0 - rtp)*ul + bf
1999  sig = rtp*ul + bf
2000  sb = ks*rtp + bf
2001  sf = ks*rtp - bf
2002  ub = ko*rtp + bf
2003  uf = ko*rtp - bf
2004  m = sqrt(att**2 - sig**2)
2005  h1 = (att + m)/sig
2006  h2 = 1.d0/h1
2007  c = (sf*sig - sb*(ks - att))/(m**2 - ks**2)
2008  d = (sb*sig + sf*(ks + att))/(m**2 - ks**2)
2009 * epso = skyl - d*sq
2010  epso = - d
2011 * epss = (rrsoil*(d + 1.d0) - c)*sq*exp(-ks)
2012  epss = (rrsoil*(d + 1.d0) - c)*exp(-ks)
2013  m11 = h1
2014  m12 = h2
2015  m21 = (1.d0 - rrsoil*h1)*exp(-m)
2016  m22 = (1.d0 - rrsoil*h2)*exp(m)
2017  det = m11*m22 - m12*m21
2018  a = (m22*epso - m12*epss)/det
2019  b = (-m21*epso + m11*epss)/det
2020  ep = integr(ko + m)
2021  em = integr(ko - m)
2022  ek = integr(ko + ks)
2023 * gp = a*ep + b*em + c*ek*sq
2024  gp = a*ep + b*em + c*ek
2025 * gm = h1*a*ep + h2*b*em + d*ek*sq
2026  gm = h1*a*ep + h2*b*em + d*ek
2027 * ems = h1*a*exp(-m) + h2*b*exp(m) + d*sq*exp(-ks)
2028  ems = h1*a*exp(-m) + h2*b*exp(m) + d*exp(-ks)
2029  rplants = uf*gp + ub*gm
2030  rdsoil = rrsoil*ems*exp(-ko)
2031  bd = rplants + rdsoil
2032 c
2033  return
2034  end
2035 *
2036 **********************************************************************
2037 *
2038  subroutine glak(glth, th)
2039 c elliptical distribution
2040 c A.Kuusk 1.03.1988
2041 c
2042  implicit double precision (a-h, o-z)
2043  save /aaa/, /ladak/
2044  save bb, es, tms
2045 c
2046  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
2047  common /ladak/ ee, thm, sthm, cthm
2048 c
2049  data bb/1.d0/, es/0.d0/, tms/0.d0/, eps/.1d0/
2050 c
2051 * print *, 'gl'
2052 c
2053  if (ee .lt. eps) then
2054  glth = 1.d0
2055  return
2056  endif
2057 c
2058  if (ee .eq. 1.d0) ee = .999999d0
2059  if ((ee .ne. es) .or. (thm .ne. tms)) then
2060  u1 = ee*cthm
2061  u3 = ee*sthm
2062  u2 = sqrt(1.d0 - u1*u1)
2063  u4 = sqrt(1.d0 - u3*u3)
2064  x = log((u4 + u1)/(u2 - u3))
2065  x1 = atan2(u3, u4) - atan2(u1, u2)
2066  x2 = sthm*x - cthm*x1
2067  bb = ee/x2
2068  es = ee
2069  tms = thm
2070  endif
2071 c
2072  glth = bb/sqrt(1.d0 - (ee*cos(thm - th))**2)
2073 c
2074  return
2075  end
2076 *
2077 ******************************************************************
2078 *
2079  subroutine gmf(gf)
2080 c Fresnel' reflection A.Kuusk 02.01.1991
2081 c input parameters are ca = cos(th_incident), rn=refract.ind.,
2082 c rk = leaf hair index
2083 c
2084  implicit double precision (a-h, o-z)
2085  save /aaa/, /ggg/
2086 c
2087  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
2088  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
2089  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
2090  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
2091  & alph, salph, alpp, difmy, difsig
2092  common /cfresn/ rn, rk
2093 c
2094  data pi12/1.570796326794895d0/
2095 c
2096 * print *, 'gmf'
2097 c
2098  ca=calp2
2099  x2 = ca*ca
2100  ag = x2*2.d0 - 1.d0 + rn*rn
2101  bg = 1.d0 + (ag - 2.d0)*x2
2102  xy = ag - x2
2103  cg = 2.d0*ca*sqrt(xy)
2104  sa2 = 1.d0 - x2
2105  y = (bg + sa2*cg)*(ag + cg)
2106  y = (ag - cg)*bg/y
2107  yy = sqrt(sa2)/pi12/ca*rk
2108  gf = exp(-yy)*y
2109 c
2110  return
2111  end
2112 *
2113 ******************************************************************
2114 *
2115  subroutine soil
2116 c Soil directional reflectance and reflectance (albedo)
2117 c th, th1, th2 in radianes, cp = cos(phi)
2118 c A.Kuusk 1.03.1988
2119 c
2120  implicit double precision (a-h, o-z)
2121  save a, b, c, cts, ths1, ths2
2122  save /count/, /soildata/, /aaa/, /ggg/
2123 c
2124  dimension phis1(200), phis2(200), phis3(200), phis4(200)
2125  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
2126  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
2127 c
2128  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
2129  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
2130  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
2131  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
2132  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
2133  & alph, salph, alpp, difmy, difsig
2134 c
2135  data a/.45098d0/, b/5.7829d0/, c, cts/2*13.7575d0/
2136  data ths1, ths2/2*.785398163d0/
2137 c
2138 * print *, 'soil'
2139  if (th2 .ne. ths2) then
2140  cts = 16.41d0 - th2*th2*4.3d0
2141  ths2 = th2
2142  endif
2143  if (th1 .ne. ths1) then
2144  ths1 = th1
2145  x = th1*th1
2146  a = x*7.702d0 - 4.3d0
2147  b = th1*7.363d0
2148  c = 16.41d0 - x*4.3d0
2149  endif
2150  x2 = rsl/cts
2151  rsoil = ((a*th + b*cp)*th + c)*x2
2152  rr1soil = (.7337d0*a + c)*x2
2153  rrsoil = 14.25d0*x2
2154 c
2155  return
2156  end
2157 *
2158 ******************************************************************
2159 *
2160  subroutine soilspec
2161 c
2162 c Soil spectral reflectance, Price, RSE 33:113 - 121 (1990)
2163 c
2164  implicit double precision (a-h, o-z)
2165  save /count/, /soildata/
2166 c
2167  dimension u1(10), u2(10), a1(10), a2(10)
2168  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
2169 c
2170  dimension phis1(200), phis2(200), phis3(200), phis4(200)
2171  common /soildata/phis1, phis2, phis3, phis4, rsl1, rsl2,
2172  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
2173 c
2174  rsl = rsl1*phis1(jl) + rsl2*phis2(jl) +
2175  & rsl3*phis3(jl) + rsl4*phis4(jl)
2176 c
2177  return
2178  end
2179 *
2180 **********************************************************************
2181 *
2182  subroutine gmd92
2183 c phase function and G-funktion
2184 c A. Kuusk 22.03.1988 & 16.06.1992
2185 c 0< = th, th1, th2<=pi/2, 0<=phi<=pi
2186 c
2187  implicit double precision (a-h, o-z)
2188  dimension f(5)
2189  save /aaa/, /ggg/, /ladak/
2190 c
2191  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
2192  common /ggg/ gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
2193  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
2194  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
2195  & alph, salph, alpp, difmy, difsig
2196  common /ladak/ ee, thm, sthm, cthm
2197 c
2198  data pi/3.14159265358979d0/, pi4/6.28318531717958d0/,
2199  & pi12/.159154943d0/, pi14/.636619773d0/, eps5/.1d-2/
2200  & , pi13/.1061032953d0/
2201 c
2202 * print *, 'gmd92'
2203 c
2204 c *** gammad, e = 0. ***
2205  gr0 = (salph + alpp*calph)*pi13
2206  gt0 = (salph - alph*calph)*pi13
2207  if (ee .lt. .4d0) then
2208  gr = gr0
2209  gt = gt0
2210  g = .5d0
2211  g1 = .5d0
2212  return
2213  endif
2214 c *** gammad, e = 1. ***
2215  sg = 0.d0
2216  sg1 = 0.d0
2217  sgmr = 0.d0
2218  sgmt = 0.d0
2219  if (th22 .lt. t11) goto 47
2220  assign 46 to l4
2221  goto 61
2222 c
2223 46 continue
2224  assign 48 to l4
2225  goto 64
2226 c
2227 47 continue
2228  if (th22 .lt. t10) goto 50
2229  assign 51 to l4
2230  goto 62
2231 c
2232 51 continue
2233  assign 46 to l4
2234  goto 65
2235 c
2236 50 continue
2237  assign 52 to l4
2238  goto 63
2239 c
2240 52 continue
2241  assign 48 to l4
2242  goto 65
2243 c
2244 48 continue
2245 c
2246  gr1 = sgmr*pi12
2247  gt1 = sgmt*pi12
2248  gr = gr0 - .0102d0 +
2249  & (1.742d0*difmy - .4557d0*difsig)*(gr1 - gr0)
2250  gt = gt0 + .00653d0 +
2251  & (.2693d0*difmy + 5.821d0*difsig)*(gt1 - gt0)
2252  g = (2.653d0*difmy + 1.432d0*difsig)*(sg - .5d0) + .50072d0
2253  g1 = (2.653d0*difmy + 1.432d0*difsig)*(sg1 - .5d0) + .50072d0
2254 c
2255 49 continue
2256  return
2257 c
2258 c ****************************** tl1 = 0., tl2=pi/2 - th1
2259 c
2260 61 assign 71 to l2
2261  goto 130
2262 71 y = pp
2263  if (y .gt. 0.d0) sgmr = sgmr + y
2264  if (y .lt. 0.d0) sgmt = sgmt - y
2265  y1 = ct1*cthm
2266  sg1 = sg1 + abs(y1)
2267  goto l4
2268 c
2269 c ****************************** tl1 = pi/2 - th1, tl2=pi/2 - th
2270 c
2271 62 continue
2272  x2 = cthm/sthm
2273  x = -ctg1*x2
2274  x1 = sqrt(1.d0 - x*x)
2275  fa = atan2(x1, x)
2276  fb = pi4 - fa
2277  assign 72 to l2
2278  goto 30
2279 c
2280 72 continue
2281  y = pp
2282  if (y .gt. 0.d0) sgmr = sgmr + y
2283  if (y .lt. 0.d0) sgmt = sgmt - y
2284  assign 73 to l2
2285  goto 130
2286 c
2287 73 y = pp - y
2288  if (y .gt. 0.d0) sgmr = sgmr + y
2289  if (y .lt. 0.d0) sgmt = sgmt - y
2290  goto l4
2291 c
2292 c ****************************** tl1 = pi/2 - th, tl2=pi/2
2293 c
2294 63 continue
2295  x2 = cthm/sthm
2296  x = -ctg1*x2
2297  x1 = sqrt(1.d0 - x*x)
2298  fa = atan2(x1, x)
2299  f(2) = fa
2300  f(3) = pi4 - fa
2301  x = -ctg*x2
2302  x1 = sqrt(1.d0 - x*x)
2303  fa = atan2(x1, x)
2304  fb = phi - fa
2305  if (fb .lt. 0.d0) fb = fb + pi4
2306  f(4) = fb
2307  f(5) = phi + fa
2308  do 75 ii = 2, 4
2309  i1 = ii + 1
2310  do 75 j = i1, 5
2311  fa = f(ii)
2312  fb = f(j)
2313  if (fb .gt. fa) goto 75
2314  f(ii) = fb
2315  f(j) = fa
2316 75 continue
2317  f(1) = f(5) - pi4
2318  i1 = 1
2319 76 ii = i1
2320  i1 = ii + 1
2321  fa = f(ii)
2322  fb = f(i1)
2323  assign 74 to l2
2324  goto 30
2325 c
2326 c ****************************** tl1 = pi/2 - th, tl2=pi/2
2327 c
2328 74 continue
2329  y = pp
2330  if (y .gt. 0.d0) sgmr = sgmr + y
2331  if (y .lt. 0.d0) sgmt = sgmt - y
2332  if (i1 .le. 4) goto 76
2333 c
2334  x2 = ct*cthm
2335  x1 = st*sthm/x2
2336  x1 = sqrt(x1*x1 - 1.d0)
2337  x = atan2(1.d0, x1)
2338  x = (x + x1)*x2
2339  y = x*pi14
2340  sg = sg + abs(y)
2341  goto l4
2342 c
2343 c ****************************** tl1 = 0, tl2=pi/2 - th
2344 c
2345 64 y1 = ct*cthm
2346  sg = sg + abs(y1)
2347  goto l4
2348 c
2349 c ****************************** tl1 = pi/2 - th1, tl2=pi/2
2350 c
2351 65 continue
2352  x2 = ct1*cthm
2353  x1 = st1*sthm/x2
2354  x1 = sqrt(x1*x1 - 1.d0)
2355  x = atan2(1.d0, x1)
2356  x = (x + x1)*x2
2357  y = x*pi14
2358  sg1 = sg1 + abs(y)
2359  goto l4
2360 c
2361 c ****************************** p(fa, fb)
2362 c
2363 30 x = fb - fa
2364  if (x .gt. eps5) goto 31
2365  pp = 0.d0
2366  goto l2
2367 31 if ((pi4 - x) .lt. eps5) goto 130
2368  sfa = sin(fa)
2369  sfb = sin(fb)
2370  cfa = cos(fa)
2371  cfb = cos(fb)
2372  pp = x*ctt1*cthm*cthm
2373  y1 = x + sfb*cfb - sfa*cfa
2374  x = cfa - cfb
2375  y1 = y1*cp + sp*x*(cfa + cfb)
2376  pp = pp + stt1*.5d0*y1*sthm*sthm
2377  y1 = s2*(sfb - sfa) + s3*x
2378  pp = pp + y1*sthm*cthm
2379  goto l2
2380 c
2381 130 x = sthm*sthm
2382  pp = calph*x + ctt1*(2.d0 - 3.d0*x)
2383  pp = pp*pi
2384  goto l2
2385 c
2386  end
2387 *
2388 ******************************************************************
2389 *
2390 *
2391 c ******************************************************************
2392 c leaf reflectance and transmittance.
2393 c Input data are refractive index n, a structure parameter N
2394 c and an absorption coefficient k:
2395 c the PROSPECT model, Jacquemoud & Baret, RSE 34:75-91 (1990)
2396 c ******************************************************************
2397 
2398  subroutine leaf
2399 c
2400  implicit double precision (a-h, o-z)
2401 c
2402  double precision nn, k, inex
2403  common /leafin/ nn, vai, k
2404  common /leafout/ refl, tran
2405  common /nagout/ inex
2406  common /tauin/ teta, ref
2407  common /tauout/ tau
2408 
2409 c ******************************************************************
2410 c determination of elementary reflectances et transmittances
2411 c ******************************************************************
2412 c ALLEN et al., 1969, Interaction of isotropic ligth with a compact
2413 c plant leaf, J. Opt. Soc. Am., Vol.59, 10:1376-1379
2414 c JACQUEMOUD S. and BARET F., 1990, Prospect : a model of leaf
2415 c optical properties spectra, Remote Sens. Environ., 34:75-91
2416 c ******************************************************************
2417 
2418 * print *, 'leaf'
2419  if (k .le. 0.d0) then
2420  k = 1.d0
2421  else
2422  call s13aaf
2423  k = (1.d0 - k)*exp(-k) + k**2*inex
2424  endif
2425 
2426  teta = 90.d0
2427  ref = nn
2428 c
2429  call tav
2430 c
2431  t1 = tau
2432  teta = 59.d0
2433 c
2434  call tav
2435 c
2436  t2 = tau
2437  x1 = 1.d0 - t1
2438  x2 = t1**2*k**2*(nn**2 - t1)
2439  x3 = t1**2*k*nn**2
2440  x4 = nn**4 - k**2*(nn**2 - t1)**2
2441  x5 = t2/t1
2442  x6 = x5*(t1 - 1.d0) + 1.d0 - t2
2443  r = x1 + x2/x4
2444  t = x3/x4
2445  ra = x5*r + x6
2446  ta = x5*t
2447 
2448 c ******************************************************************
2449 c reflectances et transmittances corresponding to N elementary
2450 c layers
2451 c ******************************************************************
2452 c STOKES G.G., 1862, On the intensity of the light reflected from or
2453 c transmitted through a pile of plates, Proceedings of the Royal
2454 c Society of London, Vol.11, 545-556
2455 c ******************************************************************
2456 
2457  delta = (t**2 - r**2 - 1.d0)**2 - 4.d0*r**2
2458  alfa = (1.d0 + r**2 - t**2 + sqrt(delta))/(2.d0*r)
2459  beta = (1.d0 + r**2 - t**2 - sqrt(delta))/(2.d0*r)
2460  va = (1.d0 + r**2 - t**2 + sqrt(delta))/(2.d0*r)
2461  vb = sqrt(beta*(alfa - r)/(alfa*(beta - r)))
2462  s1 = ra*(va*vb**(vai - 1.d0) -
2463  & va**(-1.d0)*vb**(-(vai - 1.d0))) +
2464  & (ta*t - ra*r)*(vb**(vai - 1.d0) - vb**(-(vai - 1.d0)))
2465  s2 = ta*(va - va**(-1.d0))
2466  s3 = va*vb**(vai - 1.d0) - va**(-1.d0)*vb**(-(vai - 1.d0))
2467  & - r*(vb**(vai - 1.d0) - vb**(-(vai - 1.d0)))
2468  refl = s1/s3
2469  tran = s2/s3
2470 c
2471  return
2472  end
2473 
2474 
2475 c ******************************************************************
2476 c exponential integral: int(exp(-t)/t, t = x..inf)
2477 c ******************************************************************
2478 
2479  subroutine s13aaf
2480 c
2481  implicit double precision (a-h, o-z)
2482 c
2483  double precision nn, k, inex
2484  common /leafin/ nn, vai, k
2485  common /nagout/ inex
2486 * print *, 's13aafin'
2487 
2488  if (k .gt. 4.d0) goto 10
2489 
2490  x = 0.5d0 * k - 1.d0
2491  y = (((((((((((((((-3.60311230482612224d-13
2492  & *x + 3.46348526554087424d-12)*x - 2.99627399604128973d-11)
2493  & *x + 2.57747807106988589d-10)*x - 2.09330568435488303d-9)
2494  & *x + 1.59501329936987818d-8)*x - 1.13717900285428895d-7)
2495  & *x + 7.55292885309152956d-7)*x - 4.64980751480619431d-6)
2496  & *x + 2.63830365675408129d-5)*x - 1.37089870978830576d-4)
2497  & *x + 6.47686503728103400d-4)*x - 2.76060141343627983d-3)
2498  & *x + 1.05306034687449505d-2)*x - 3.57191348753631956d-2)
2499  & *x + 1.07774527938978692d-1)*x - 2.96997075145080963d-1
2500  y = (y*x + 8.64664716763387311d-1)*x + 7.42047691268006429d-1
2501  inex = y - log(k)
2502  goto 30
2503 
2504 10 if (k .ge. 85.d0) go to 20
2505  x = 14.5d0 / (k + 3.25d0) - 1.d0
2506  y = (((((((((((((((-1.62806570868460749d-12
2507  & *x - 8.95400579318284288d-13)*x - 4.08352702838151578d-12)
2508  & *x - 1.45132988248537498d-11)*x - 8.35086918940757852d-11)
2509  & *x - 2.13638678953766289d-10)*x - 1.10302431467069770d-9)
2510  & *x - 3.67128915633455484d-9)*x - 1.66980544304104726d-8)
2511  & *x - 6.11774386401295125d-8)*x - 2.70306163610271497d-7)
2512  & *x - 1.05565006992891261d-6)*x - 4.72090467203711484d-6)
2513  & *x - 1.95076375089955937d-5)*x - 9.16450482931221453d-5)
2514  & *x - 4.05892130452128677d-4)*x - 2.14213055000334718d-3
2515  y = ((y*x - 1.06374875116569657d-2)*x -
2516  & 8.50699154984571871d-2)*x +
2517  & 9.23755307807784058d-1
2518  inex = exp(-k) * y / k
2519  goto 30
2520 
2521 20 inex = 0.d0
2522  goto 30
2523 
2524 30 continue
2525 * print *, 's13aafout'
2526  return
2527  end
2528 
2529 c ******************************************************************
2530 c determination of tav for any solid angle
2531 c ******************************************************************
2532 c STERN F., 1964, Transmission of isotropic radiation across an
2533 c interface between two dielectrics, Appl.Opt., Vol.3, 1:111-113
2534 c ALLEN W.A., 1973, Transmission of isotropic light across a
2535 c dielectric surface in two and three dimensions, J.Opt.Soc.Am.,
2536 c Vol.63, 6:664-666
2537 c ******************************************************************
2538 
2539  subroutine tav
2540 c
2541  implicit double precision (a-h, o-z)
2542  double precision k
2543 c
2544  common /tauin/ teta, ref
2545  common /tauout/ tau
2546 c
2547  data dr/1.745329251994330d-2/, eps/.1d-6/,
2548  & pi12/1.570796326794895d0/
2549 
2550 * print *, 'tavin'
2551  teta = teta*dr
2552  r2 = ref**2
2553  rp = r2 + 1.d0
2554  rm = r2 - 1.d0
2555  a = (ref + 1.d0)**2/2.d0
2556  k = -(r2 - 1.d0)**2/4.d0
2557  ds = sin(teta)
2558 
2559  if (abs(teta) .le. eps) then
2560  tau = 4.d0*ref/(ref + 1.d0)**2
2561  else
2562 
2563  if (abs(teta - pi12) .le. eps) then
2564  b1 = 0.d0
2565  else
2566  xxx = (ds**2 - rp/2.d0)**2 + k
2567  b1 = sqrt(xxx)
2568  endif
2569 
2570  b2 = ds**2 - rp/2.d0
2571  b = b1 - b2
2572  ts = (k**2/(6.d0*b**3) + k/b - b/2.d0) -
2573  & (k**2/(6.d0*a**3) + k/a - a/2.d0)
2574  tp1 = -2.d0*r2*(b - a)/rp**2
2575  tp2 = -2.d0*r2*rp*log(b/a)/rm**2
2576  tp3 = r2*(1.d0/b - 1.d0/a)/2.d0
2577  tp4 = 16.d0*r2**2*(r2**2 + 1.d0)*dlog((2.d0*rp*b - rm**2)/
2578  & (2.d0*rp*a - rm**2))/(rp**3*rm**2)
2579  tp5 = 16.d0*r2**3*(1.d0/(2.d0*rp*b - rm**2) - 1.d0/
2580  & (2.d0*rp*a - rm**2))/rp**3
2581  tp = tp1 + tp2 + tp3 + tp4 + tp5
2582  tau = (ts + tp)/(2.d0*ds**2)
2583  endif
2584 * print *, 'tavout'
2585  return
2586  end
2587 *
2588 ******************************************************************
2589 *
2590 c constant values: refractive index (ref), albino and dry leaf
2591 c absorption (ke), chlorophyll a+b specific absorption coefficient
2592 c (kab), water specific absorption coefficient (kw),
2593 * and basis functions for soil spectral reflectance phis1, phis2,
2594 * phis3 and phis4 (Price, 1990)
2595 c ******************************************************************
2596 c JACQUEMOUD S. AND BARET F., 1990, Prospect : a model of leaf
2597 c optical properties spectra, Remote Sens. Environ., 34:75-91
2598 c JACQUEMOUD S. et al., 1991, Validation d'un modele de reflectance
2599 c spectrale et directionnnelle de sol, 5ieme Colloque International
2600 c Mesures Physiques et Signatures en Teledetection, Courchevel
2601 c (France), 14-18 Janvier 1991
2602 c ******************************************************************
2603 
2604  block data valeur
2605 c
2606  implicit double precision (a-h, o-z)
2607 c
2608  double precision ke, kab, kw
2609  dimension ref(200), ke(200), kab(200), kw(200)
2610  common /dat/ ref, ke, kab, kw
2611 c
2612  dimension phis1(200), phis2(200), phis3(200), phis4(200)
2613  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
2614  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
2615 c
2616  data (ref(i), i = 1, 100)/
2617  & 1.5123,1.5094,1.5070,1.5050,1.5032,1.5019,1.5007,1.4997,1.4988,
2618  & 1.4980,1.4969,
2619  & 1.4959,1.4951,1.4943,1.4937,1.4930,1.4925,1.4920,1.4915,1.4910,
2620  & 1.4904,1.4899,1.4893,1.4887,1.4880,1.4873,1.4865,1.4856,1.4846,
2621  & 1.4836,1.4825,1.4813,1.4801,1.4788,1.4774,1.4761,1.4746,1.4732,
2622  & 1.4717,1.4701,1.4685,1.4670,1.4654,1.4639,1.4624,1.4609,1.4595,
2623  & 1.4582,1.4570,1.4559,1.4548,1.4538,1.4528,1.4519,1.4510,1.4502,
2624  & 1.4495,1.4489,1.4484,1.4480,1.4477,1.4474,1.4472,1.4470,1.4468,
2625  & 1.4467,1.4465,1.4463,1.4461,1.4458,1.4456,1.4453,1.4450,1.4447,
2626  & 1.4444,1.4440,1.4435,1.4430,1.4423,1.4417,1.4409,1.4402,1.4394,
2627  & 1.4387,1.4380,1.4374,1.4368,1.4363,1.4357,1.4352,1.4348,1.4345,
2628  & 1.4342,1.4341,1.4340,1.4340,1.4341,1.4342,1.4343,1.4345/
2629 
2630  data (ref(i), i = 101, 200)/
2631  & 1.4347,1.4348,1.4347,1.4345,1.4341,1.4336,1.4331,1.4324,1.4317,
2632  & 1.4308,1.4297,1.4284,1.4269,1.4253,1.4235,1.4216,1.4196,1.4176,
2633  & 1.4156,1.4137,1.4118,1.4100,1.4082,1.4065,1.4047,1.4029,1.4011,
2634  & 1.3993,1.3975,1.3958,1.3940,1.3923,1.3906,1.3888,1.3870,1.3851,
2635  & 1.3830,1.3808,1.3784,1.3758,1.3731,1.3703,1.3676,1.3648,1.3620,
2636  & 1.3592,1.3565,1.3537,1.3510,1.3484,1.3458,1.3433,1.3410,1.3388,
2637  & 1.3368,1.3350,1.3333,1.3317,1.3303,1.3289,1.3275,1.3263,1.3251,
2638  & 1.3239,1.3228,1.3217,1.3205,1.3194,1.3182,1.3169,1.3155,1.3140,
2639  & 1.3123,1.3105,1.3086,1.3066,1.3046,1.3026,1.3005,1.2985,1.2964,
2640  & 1.2944,1.2923,1.2902,1.2882,1.2863,1.2844,1.2826,1.2808,1.2793,
2641  & 1.2781,1.2765,1.2750,1.2738,1.2728,1.2719,1.2712,1.2708,1.2712,
2642  & 1.2736/
2643 
2644  data (ke(i), i = 1, 100)/
2645  &.1104,.0893,.0714,.0567,.0442,.0348,.0279,.0232,.0197,.0173,.0154,
2646  &.0142,.0120,.0108,.0093,.0092,.0092,.0092,.0092,.0092,.0091,.0091,
2647  &.0091,.0091,.0091,.0090,.0090,.0090,.0090,.0090,.0089,.0089,.0089,
2648  &.0089,.0088,.0088,.0088,.0088,.0088,.0087,.0087,.0087,.0087,.0087,
2649  &.0086,.0086,.0086,.0086,.0086,.0085,.0085,.0085,.0085,.0085,.0084,
2650  &.0084,.0084,.0084,.0084,.0083,.0083,.0083,.0082,.0082,.0082,.0082,
2651  &.0082,.0081,.0081,.0081,.0081,.0081,.0080,.0080,.0080,.0080,.0080,
2652  &.0079,.0079,.0079,.0079,.0079,.0078,.0078,.0078,.0078,.0078,.0077,
2653  &.0077,.0077,.0077,.0077,.0076,.0076,.0076,.0076,.0076,.0075,.0075,
2654  &.0075/
2655 
2656  data (ke(i), i = 101, 200)/
2657  &.0074,.0073,.0072,.0071,.0070,.0069,.0068,.0068,.0067,.0066,.0065,
2658  &.0064,.0063,.0062,.0062,.0061,.0060,.0059,.0058,.0057,.0056,.0056,
2659  &.0054,.0053,.0053,.0052,.0051,.0050,.0049,.0048,.0047,.0047,.0046,
2660  &.0045,.0044,.0043,.0042,.0041,.0040,.0039,.0039,.0037,.0037,.0036,
2661  &.0035,.0034,.0033,.0032,.0031,.0031,.0030,.0029,.0028,.0027,.0026,
2662  &.0025,.0025,.0024,.0023,.0022,.0021,.0020,.0019,.0019,.0018,.0017,
2663  &.0016,.0015,.0014,.0014,.0013,.0012,.0010,.0010,.0009,.0008,.0007,
2664  &.0006,.0006,.0005,.0004,.0003,.0002,.0002,.0001,15*.0000/
2665 
2666  data kab/
2667  & .04664,.04684,.04568,.04482,.04344,.04257,.04287,.04189,.04116,
2668  & .03847,.03409,
2669  & .03213,.03096,.03116,.03051,.03061,.02998,.02965,.02913,.02902,
2670  & .02769,.02707,.02539,.02409,.02150,.01807,.01566,.01317,.01095,
2671  & .00929,.00849,.00803,.00788,.00757,.00734,.00713,.00692,.00693,
2672  & .00716,.00758,.00815,.00877,.00938,.00976,.01041,.01089,.01105,
2673  & .01127,.01170,.01222,.01280,.01374,.01441,.01462,.01495,.01499,
2674  & .01506,.01580,.01686,.01810,.01961,.02112,.02336,.02702,.02880,
2675  & .02992,.03142,.03171,.02961,.02621,.02078,.01518,.01020,.00718,
2676  & .00519,.00390,.00298,.00218,.00163,.00116,.00083,.00057,.00039,
2677  & .00027,.00014,.00011,.00009,.00005,112*.00000/
2678 
2679  data kw/
2680  & 111*0.,00.100,00.200,00.278,00.206,00.253,00.260,00.313,00.285,
2681  & 00.653,00.614,00.769,00.901,00.872,00.812,00.733,00.724,00.855,
2682  & 00.900,01.028,01.500,02.026,02.334,03.636,08.942,14.880,17.838,
2683  & 19.497,19.419,17.999,12.024,10.709,08.384,07.081,06.155,05.619,
2684  & 05.112,04.512,04.313,04.064,03.804,03.709,03.877,04.348,04.574,
2685  & 05.029,05.804,06.345,05.823,05.886,06.315,08.432,15.588,32.247,
2686  & 51.050,58.694,55.135,50.454,42.433,40.670,36.030,29.771,25.153,
2687  & 24.378,22.008,20.608,18.576,17.257,15.921,14.864,12.861,12.773,
2688  & 12.426,13.090,14.013,15.066,15.857,16.776,19.113,21.066,22.125,
2689  & 26.438,28.391,28.920,31.754,36.375,40.056,41.019,45.471,43.126/
2690 
2691  data (phis1(i), i = 1, 100)/
2692  & .088, .095, .102, .109, .116, .123, .130, .136, .143, .150,
2693  & .157, .164, .171, .178, .185, .192, .199, .206, .213, .220,
2694  & .227, .233, .240, .247, .254, .261, .268, .275, .282, .289,
2695  & .295, .302, .309, .316, .326, .335, .345, .356, .366, .376,
2696  & .386, .395, .404, .412, .421, .429, .436, .443, .450, .457,
2697  & .464, .470, .476, .483, .489, .495, .502, .508, .514, .520,
2698  & .526, .532, .538, .543, .549, .555, .561, .568, .574, .580,
2699  & .587, .594, .601, .608, .615, .622, .629, .637, .644, .652,
2700  & .659, .667, .674, .681, .689, .696, .702, .709, .716, .723,
2701  & .729, .735, .742, .748, .754, .760, .766, .771, .777, .782/
2702 
2703  data (phis1(i), i = 101, 200)/
2704  & .802, .819, .832, .842, .854, .868, .883, .899, .917, .935,
2705  & .954, .974, .993,1.012,1.030,1.047,1.063,1.078,1.091,1.102,
2706  & 1.111,1.118,1.126,1.137,1.150,1.163,1.176,1.187,1.192,1.188,
2707  & 1.177,1.159,1.134,1.090, .979, .830, .764, .744, .748, .777,
2708  & .823, .878, .932, .983,1.026,1.062,1.091,1.115,1.133,1.147,
2709  & 1.156,1.161,1.162,1.158,1.149,1.132,1.109,1.087,1.072,1.056,
2710  & 1.035, .989, .886, .659, .456, .350, .323, .335, .361, .396,
2711  & .438, .484, .530, .576, .622, .664, .705, .740, .768, .788,
2712  & .800, .802, .796, .794, .797, .789, .779, .756, .725, .715,
2713  & .675, .635, .585, .535, .485, .435, .385, .335, .285, .235/
2714 
2715  data (phis2(i), i = 1, 100)/
2716  & .249, .245, .241, .237, .232, .228, .222, .217, .211, .205,
2717  & .199, .193, .186, .179, .171, .163, .155, .147, .139, .130,
2718  & .121, .111, .102, .092, .081, .071, .060, .049, .038, .026,
2719  & .014, .002,-.011,-.024,-.037,-.050,-.064,-.078,-.092,-.107,
2720  & -.121,-.137,-.152,-.168,-.184,-.200,-.216,-.232,-.246,-.259,
2721  & -.270,-.280,-.289,-.297,-.303,-.308,-.313,-.317,-.322,-.325,
2722  & -.329,-.332,-.335,-.338,-.340,-.342,-.345,-.347,-.350,-.352,
2723  & -.355,-.358,-.360,-.363,-.366,-.369,-.372,-.374,-.377,-.378,
2724  & -.380,-.381,-.382,-.382,-.383,-.382,-.382,-.381,-.380,-.378,
2725  & -.376,-.373,-.370,-.367,-.363,-.359,-.354,-.349,-.344,-.338/
2726 
2727  data (phis2(i), i = 101, 200)/
2728  & -.310,-.283,-.258,-.234,-.212,-.190,-.167,-.143,-.118,-.092,
2729  & -.066,-.039,-.014, .011, .034, .057, .083, .114, .151, .192,
2730  & .233, .272, .311, .348, .380, .407, .438, .476, .521, .570,
2731  & .624, .674, .708, .766, .824, .853, .854, .852, .858, .881,
2732  & .916, .947, .973, .997,1.017,1.036,1.052,1.067,1.082,1.095,
2733  & 1.107,1.119,1.131,1.142,1.154,1.166,1.175,1.179,1.178,1.172,
2734  & 1.162,1.148,1.083, .900, .678, .538, .499, .515, .552, .598,
2735  & .653, .716, .777, .834, .886, .932, .973,1.007,1.036,1.058,
2736  & 1.075,1.086,1.091,1.091,1.086,1.076,1.060,1.039,1.012, .980,
2737  & .943, .900, .852, .799, .740, .676, .606, .532, .451, .366/
2738 
2739  data (phis3(i), i = 1, 100)/
2740  & -.417,-.384,-.351,-.318,-.285,-.253,-.221,-.189,-.157,-.126,
2741  & -.095,-.064,-.033,-.003, .027, .057, .087, .117, .146, .175,
2742  & .204, .232, .260, .289, .316, .344, .371, .399, .425, .452,
2743  & .478, .505, .525, .545, .566, .587, .606, .626, .652, .676,
2744  & .699, .722, .744, .764, .784, .804, .822, .839, .856, .872,
2745  & .886, .900, .913, .926, .937, .948, .957, .966, .974, .981,
2746  & .988, .993, .998,1.002,1.006,1.009,1.012,1.014,1.016,1.017,
2747  & 1.018,1.018,1.018,1.017,1.016,1.014,1.012,1.010,1.007,1.003,
2748  & .999, .995, .990, .984, .978, .972, .965, .957, .949, .941,
2749  & .932, .923, .913, .902, .891, .880, .868, .855, .842, .829/
2750 
2751  data (phis3(i), i = 101, 200)/
2752  & .766, .694, .620, .550, .484, .421, .361, .303, .247, .190,
2753  & .134, .079, .023,-.031,-.086,-.140,-.190,-.235,-.275,-.310,
2754  & -.340,-.367,-.394,-.422,-.452,-.484,-.513,-.541,-.565,-.578,
2755  & -.575,-.556,-.525,-.468,-.323,-.115,-.018, .002,-.003,-.029,
2756  & -.076,-.142,-.211,-.274,-.333,-.386,-.432,-.471,-.503,-.528,
2757  & -.544,-.551,-.549,-.538,-.517,-.491,-.463,-.436,-.419,-.417,
2758  & -.401,-.348,-.216, .014, .160, .203, .209, .210, .207, .200,
2759  & .189, .174, .155, .132, .105, .075, .043, .013,-.012,-.035,
2760  & -.053,-.068,-.078,-.082,-.080,-.073,-.060,-.041,-.017, .006,
2761  & .035, .065, .097, .125, .168, .180, .168, .125, .097, .065/
2762 
2763  data (phis4(i), i = 1, 100)/
2764  & .067, .077, .086, .094, .102, .111, .118, .126, .133, .140,
2765  & .146, .152, .158, .164, .169, .174, .179, .184, .188, .192,
2766  & .195, .198, .201, .204, .206, .208, .210, .212, .213, .214,
2767  & .214, .214, .214, .214, .213, .212, .211, .210, .210, .209,
2768  & .207, .205, .202, .198, .194, .189, .184, .179, .173, .167,
2769  & .161, .155, .149, .143, .136, .130, .123, .116, .108, .101,
2770  & .093, .085, .077, .068, .060, .051, .043, .034, .026, .018,
2771  & .010, .002,-.006,-.014,-.022,-.030,-.037,-.045,-.052,-.060,
2772  & -.067,-.074,-.081,-.087,-.093,-.098,-.103,-.108,-.112,-.116,
2773  & -.120,-.123,-.126,-.129,-.132,-.134,-.136,-.138,-.140,-.141/
2774 
2775  data (phis4(i), i = 101, 200)/
2776  & -.147,-.152,-.158,-.166,-.170,-.165,-.157,-.151,-.144,-.128,
2777  & -.104,-.078,-.049,-.009, .038, .082, .122, .169, .222, .272,
2778  & .317, .364, .413, .469, .532, .591, .642, .694, .748, .790,
2779  & .810, .817, .819, .740, .494, .215, .110, .125, .155, .204,
2780  & .291, .408, .521, .627, .724, .811, .884, .940, .987,1.025,
2781  & 1.053,1.071,1.077,1.072,1.046, .996, .941, .892, .857, .842,
2782  & .809, .713, .509, .055,-.236,-.324,-.336,-.320,-.308,-.294,
2783  & -.275,-.248,-.205,-.144,-.094,-.048, .005, .058, .105, .132,
2784  & .123, .079, .045, .024, .014, .018, .022,-.010,-.042,-.054,
2785  & -.055,-.060,-.060,-.055,-.050,-.046,-.042,-.038,-.034,-.030/
2786 
2787  end
2788 *
2789 ******************************************************************
2790 *
2791  subroutine dakg(u, a, nq)
2792 c Gaussi kvadratuuri sqlmed ja kordajad, nq = 2*n, u=(-1., 1.)
2793  implicit double precision (a-h, o-z)
2794  dimension u(48), a(48)
2795 c
2796 * print *,'dakg'
2797  n = nq/2
2798  goto (1, 2, 1, 4, 1, 6, 1, 8, 1, 10, 1, 12, 1, 14, 1, 16, 1,
2799  & 1, 1, 20, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
2800  & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 48), nq
2801 1 continue
2802  print *, ' *** dakg - inacceptable nq'
2803  stop 'dakg'
2804 c
2805 2 continue
2806  u(2) = .577350269189626d0
2807  a(2) = 1.d0
2808  goto 13
2809 c
2810 4 continue
2811  u(3) = .339981043584856d0
2812  u(4) = .861136311594053d0
2813  a(3) = .652145154862546d0
2814  a(4) = .347854845137454d0
2815  goto 13
2816 c
2817 6 continue
2818  u(4) = .238619186083197d0
2819  u(5) = .661209386466265d0
2820  u(6) = .932469514203152d0
2821  a(4) = .467913934572691d0
2822  a(5) = .360761573048139d0
2823  a(6) = .171324492379170d0
2824  goto 13
2825 c
2826 8 continue
2827  u(5) = .183434642495650d0
2828  u(6) = .525532409916329d0
2829  u(7) = .796666477413627d0
2830  u(8) = .960289856497536d0
2831  a(5) = .362683783378362d0
2832  a(6) = .313706645877887d0
2833  a(7) = .222381034453374d0
2834  a(8) = .101228536290376d0
2835  goto 13
2836 c
2837 10 continue
2838  u(6) = .148874338981631d0
2839  u(7) = .433395394129247d0
2840  u(8) = .679409568299024d0
2841  u(9) = .865063366688985d0
2842  u(10) = .973906528517172d0
2843  a(6) = .295524224714753d0
2844  a(7) = .269266719309996d0
2845  a(8) = .219086362515982d0
2846  a(9) = .149451349150580d0
2847  a(10) = .666713443086881d-1
2848  goto 13
2849 c
2850 12 continue
2851  u(7) = .125233408511469d0
2852  u(8) = .367831498998180d0
2853  u(9) = .587317954286617d0
2854  u(10) = .769902674194305d0
2855  u(11) = .904117256370475d0
2856  u(12) = .981560634246719d0
2857  a(7) = .249147045813402d0
2858  a(8) = .233492536538355d0
2859  a(9) = .203167426723066d0
2860  a(10) = .160078328543346d0
2861  a(11) = .106939325995318d0
2862  a(12) = .471753363865118d-1
2863  goto 13
2864 c
2865 14 continue
2866  u( 8) = .108054948707344d0
2867  u( 9) = .319112368927890d0
2868  u(10) = .515248636358154d0
2869  u(11) = .687292904811685d0
2870  u(12) = .827201315069765d0
2871  u(13) = .928434883663574d0
2872  u(14) = .986283808696812d0
2873  a( 8) = .215263853463158d0
2874  a( 9) = .205198463721296d0
2875  a(10) = .185538397477938d0
2876  a(11) = .157203167158194d0
2877  a(12) = .121518570687903d0
2878  a(13) = .801580871597602d-1
2879  a(14) = .351194603317519d-1
2880  goto 13
2881 c
2882 16 continue
2883  u( 9) = .950125098376374d-1
2884  u(10) = .281603550779259d0
2885  u(11) = .458016777657227d0
2886  u(12) = .617876244402643d0
2887  u(13) = .755404408355003d0
2888  u(14) = .865631202387832d0
2889  u(15) = .944575023073233d0
2890  u(16) = .989400934991650d0
2891  a( 9) = .189450610455068d0
2892  a(10) = .182603415044924d0
2893  a(11) = .169156519395003d0
2894  a(12) = .149595988816577d0
2895  a(13) = .124628971255534d0
2896  a(14) = .951585116824928d-1
2897  a(15) = .622535239386479d-1
2898  a(16) = .271524594117541d-1
2899  goto 13
2900 c
2901 20 continue
2902  u(11) = .765265211334973d-1
2903  u(12) = .227785851141645d0
2904  u(13) = .373706088715420d0
2905  u(14) = .510867001950827d0
2906  u(15) = .636053680726515d0
2907  u(16) = .746331906460151d0
2908  u(17) = .839116971822219d0
2909  u(18) = .912234428251326d0
2910  u(19) = .963971927277914d0
2911  u(20) = .993128599185095d0
2912  a(11) = .152753387130726d0
2913  a(12) = .149172986472604d0
2914  a(13) = .142096109318382d0
2915  a(14) = .131688638449177d0
2916  a(15) = .118194531961518d0
2917  a(16) = .101930119817240d0
2918  a(17) = .832767415767047d-1
2919  a(18) = .626720483341091d-1
2920  a(19) = .406014298003869d-1
2921  a(20) = .176140071391521d-1
2922  goto 13
2923 c
2924 48 continue
2925  u(25) = .323801709628694d-1
2926  u(26) = .970046992094627d-1
2927  u(27) = .161222356068892d0
2928  u(28) = .224763790394689d0
2929  u(29) = .287362487355456d0
2930  u(30) = .348755886292161d0
2931  u(31) = .408686481990717d0
2932  u(32) = .466902904750958d0
2933  u(33) = .523160974722233d0
2934  u(34) = .577224726083973d0
2935  u(35) = .628867396776514d0
2936  u(36) = .677872379632664d0
2937  u(37) = .724034130923815d0
2938  u(38) = .767159032515740d0
2939  u(39) = .807066204029443d0
2940  u(40) = .843588261624394d0
2941  u(41) = .876572020274247d0
2942  u(42) = .905879136715570d0
2943  u(43) = .931386690706554d0
2944  u(44) = .952987703160431d0
2945  u(45) = .970591592546247d0
2946  u(46) = .984124583722827d0
2947  u(47) = .993530172266351d0
2948  u(48) = .998771007252426d0
2949  a(25) = .647376968126839d-1
2950  a(26) = .644661644359501d-1
2951  a(27) = .639242385846482d-1
2952  a(28) = .631141922862540d-1
2953  a(29) = .620394231598927d-1
2954  a(30) = .607044391658939d-1
2955  a(31) = .591148396983956d-1
2956  a(32) = .572772921004032d-1
2957  a(33) = .551995036999842d-1
2958  a(34) = .528901894851937d-1
2959  a(35) = .503590355538545d-1
2960  a(36) = .476166584924905d-1
2961  a(37) = .446745608566943d-1
2962  a(38) = .415450829434647d-1
2963  a(39) = .382413510658307d-1
2964  a(40) = .347772225647704d-1
2965  a(41) = .311672278327981d-1
2966  a(42) = .274265097083569d-1
2967  a(43) = .235707608393244d-1
2968  a(44) = .196161604573555d-1
2969  a(45) = .155793157229438d-1
2970  a(46) = .114772345792345d-1
2971  a(47) = .732755390127626d-2
2972  a(48) = .315334605230584d-2
2973 13 continue
2974 c
2975  nq1 = nq+1
2976  do 15 i = 1,n
2977  ii = nq1-i
2978  u(i) = -u(ii)
2979  a(i) = a(ii)
2980 15 continue
2981 c
2982  return
2983  end
2984 *
2985 ******************************************************************
2986 c akbrdf - an interface between 6s and msrm
2987 c MSRM93 - MultiSpectral Reflectance Model A. Kuusk 24.03.1993
2988 c Internet: andres@aai.ee
2989 c
2990 c A. Kuusk, A multispectral canopy reflectance model,
2991 c Remote Sens. Environ., 1994, 50(2):75-82.
2992 c
2993  subroutine akbrdf(eei, thmi, uli, sli, rsl1i, wlmoy, rnci,
2994  & cabi, cwi, vaii, mu, np, rm, rp, brdfint)
2995 c See on tegelikult juba mcrm, aga clx ja clz on fikseeritud
2996 c
2997  implicit double precision (a-h, o-z)
2998  integer np, mu
2999  integer k, j
3000  real eei, thmi, uli, sli, rsl1i, wlmoy, rnci, cabi, cwi,
3001  & vaii, pir
3002  real mu1, mu2, fi
3003  real rm(-mu:mu), rp(np), brdfint(-mu:mu, np)
3004  save /count/, /soildata/, /aaa/, /ggg/, /ladak/
3005 c
3006  dimension u1(10), u2(10), a1(10), a2(10)
3007  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
3008 c
3009  double precision nnl, kk, integr
3010  common /leafin/ nnl, vai, kk
3011  common /leafout/ refl, tran
3012 c
3013  double precision ke, kab, kw
3014  dimension refr(200), ke(200), kab(200), kw(200)
3015  common /dat/ refr, ke, kab, kw
3016 c
3017  dimension phis1(200), phis2(200), phis3(200), phis4(200)
3018  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
3019  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
3020 c
3021  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
3022  common /ggg/gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
3023  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
3024  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
3025  & alph, salph, alpp, difmy, difsig
3026  common /cfresn/ rn, rk
3027  common /ladak/ ee, thm, sthm, cthm
3028  common /msrmdata/ th10, rncoef, cab, cw, bq
3029 c
3030 c
3031  data pi/3.141592653589793d0/, pir/3.14159265/
3032  data pi12/1.570796326794895d0/, dr/1.745329251994330d-2/
3033  data eps/.1d-5/, eps4/.1d-3/
3034 c--- data lf/1/
3035 c
3036 * print *, 'msrm93'
3037 c
3038  integr(xx) = (1.d0 - exp(-xx))/xx
3039  jg = 1
3040 * if (lf .eq. 1) then
3041 c
3042  ee = eei
3043  thm = thmi*dr
3044  ul = uli
3045  sl = sli
3046  clz = .9d0
3047  clx = .1d0
3048  th2 = 45.d0*dr
3049  rsl1 = rsl1i
3050  rsl2 = -.48d0*rsl1 + .0862d0
3051  rsl3 = 0.d0
3052  rsl4 = 0.d0
3053  rlambda = wlmoy*1000.d0
3054 c
3055  if ((rlambda .gt. 2500.d0) .or. (rlambda .lt. 404.d0)) then
3056  print *, 'AKBRDF: wavelength out of range'
3057  stop
3058  endif
3059 c
3060  if (rlambda .le. 800.d0) then
3061  jl = nint((rlambda - 400.d0)/4.d0)
3062  else
3063  jl = nint((rlambda - 800.d0)/17.d0) + 100
3064  endif
3065 c
3066  rncoef = rnci
3067  cab = cabi
3068  cw = cwi
3069  vai = vaii
3070  nnl = refr(jl)
3071  kk = ke(jl) + cab*kab(jl) + cw*kw(jl)
3072  call leaf
3073 c
3074  rn = rncoef*nnl
3075  rrl = refl - ((1.d0 - rn)/(1.d0 + rn))**2
3076  rrls = rrl
3077  ttl = tran
3078 c
3079  call soilspec
3080 c
3081  cthm = cos(thm)
3082  sthm = sin(thm)
3083 c
3084  th22 = pi12 - thm
3085  if (abs(th22) .lt. eps4) th22 = 0.d0
3086  eln = -log(1.d0 - ee)
3087  difmy = abs(.059d0*eln*(thm - 1.02d0) + .02d0)
3088  difsig = abs(.01771d0 - .0216d0*eln*(thm - .256d0))
3089 c
3090 * lf = 2
3091 * endif
3092 c
3093  sth10 = sin(th10)
3094  cth10 = cos(th10)
3095 c
3096  mu1 = rm(0)
3097  do 1 k = 1, np
3098  do 2 j = 1, mu
3099  mu2 = rm(j)
3100  if (j .eq. mu) then
3101  fi = rm(-mu)
3102  else
3103  fi = rp(k) + rm(-mu)
3104  endif
3105  th10 = acos(mu1)
3106  if (fi .lt. 0.) fi = fi + 2.*pir
3107  if (fi .gt. (2.*pir)) fi = fi - 2.*pir
3108  if (fi .gt. pir) fi = 2.*pir - fi
3109  tgt1 = tan(th10)
3110  xx = tgt1*clx/sl
3111 c
3112  if (xx .lt. eps) then
3113  clmp1 = clz
3114  else
3115  clmp1 = 1.d0 - (1.d0 - clz)*integr(xx)
3116  endif
3117 c
3118  phi = fi
3119  th1 = th10
3120  th = acos(mu2)
3121  tgt = tan(th)
3122  xx = tgt*clx/sl
3123 c
3124  if (xx .lt. eps) then
3125  clmp = clz
3126  else
3127  clmp = 1.d0 - (1.d0 - clz)*integr(xx)
3128  endif
3129 c
3130  call msrm
3131  brdfint(j, k) = bq
3132 c
3133  2 continue
3134  1 continue
3135 c
3136  return
3137  end
3138 *
3139 *
3140 ******************************************************************
3141 *
3142 
3143  subroutine akalbe
3144 * & (eei, thmi, uli, sli, rsl1i, wlmoy, rnci, cabi, cwi, vaii, albbrdf)
3145  & (albbrdf)
3146 c
3147 c aa94.f - albeedo integrating msrm93 over the hemisphere
3148 c A. Kuusk 23.09.1994
3149 c
3150  implicit double precision (a-h, o-z)
3151 c
3152 * real eei, thmi, uli, sli, rsl1i, wlmoy, rnci, cabi, cwi, vaii, albbrdf
3153  real albbrdf
3154  save /count/, /soildata/, /aaa/, /ggg/, /ladak/
3155 c
3156  dimension uu(20), aa(20)
3157 c
3158  dimension u1(10), u2(10), a1(10), a2(10)
3159  common /count/ jl, jj, lg, jg, lf, nnx, n1, n2, u1, u2, a1, a2
3160 c
3161  dimension phis1(200), phis2(200), phis3(200), phis4(200)
3162  common /soildata/ phis1, phis2, phis3, phis4, rsl1, rsl2,
3163  & rsl3, rsl4, th2, rsl, rsoil, rr1soil, rrsoil
3164 c
3165  common /aaa/ rrl, ttl, ul, sl, clmp, clmp1, bi, bd, bqint
3166  common /ggg/gr, gt, g, g1, th, sth, cth, th1, sth1, cth1,
3167  & phi, sp, cp, th22, st, ct, st1, ct1, t10, t11, e1, e2,
3168  & s2, s3, ctg, ctg1, ctt1, stt1, calph, alp2, salp2, calp2,
3169  & alph, salph, alpp, difmy, difsig
3170  common /ladak/ ee, thm, sthm, cthm
3171 c
3172  data pi/3.141592653589793d0/, pi1/1.5707963268d0/
3173 c
3174 * print *, 'aa94'
3175 c
3176  n1 = 6
3177  n2 = 8
3178 c
3179  n = n2 + n2
3180  ng = n + 1
3181  call dakg(uu, aa, n)
3182 c
3183  do 20 i = 1, n2
3184  i1 = ng - i
3185  a2(i) = aa(i)
3186 20 u2(i) = uu(i1)
3187 c
3188  n = n1 + n1
3189  ng = n + 1
3190  call dakg(uu, aa, n)
3191 c
3192  do 21 i = 1, n1
3193  i1 = ng - i
3194  a1(i) = aa(i)
3195 21 u1(i) = uu(i1)
3196 c
3197  bdd = 0.d0
3198  do 10 i2 = 1, n2
3199  th = (1.d0 - u2(i2))*pi1
3200  sth = sin(th)
3201  cth = cos(th)
3202 c
3203  call akd
3204 c
3205  bdd = bdd + a2(i2)*bqint*sth*cth
3206 10 continue
3207 c
3208  albbrdf = bdd*pi
3209 c
3210  return
3211  end
3212 *
3213 ******************************************************************
3214 *
3215  subroutine atmref (iaer,tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt,
3216  s phi,xmus,xmuv,
3217  s phirad,nt,mu,np,rm,gb,rp,
3218  a rorayl,roaero,romix,xlm1,xlm2)
3219  integer mu,np
3220  real rm(-mu:mu),rp(np),gb(-mu:mu),xlm1(-mu:mu,np)
3221  real xlm2(-mu:mu,np)
3222  real tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt
3223  real phi,xmus,xmuv,phirad
3224  real rorayl,roaero,romix,delta,sigma,tamol,tamolp
3225  integer iaer,nt
3226  common /sixs_del/ delta,sigma
3227 c atmospheric reflectances
3228 c
3229  rorayl=0.
3230  roaero=0.
3231 c rayleigh reflectance 3 cases (satellite,plane,ground)
3232  if(palt.lt.900..and.palt.gt.0.0)then
3233  rm(-mu)=-xmuv
3234  rm(mu)=xmuv
3235  rm(0)=-xmus
3236  tamol=0.
3237  tamolp=0.
3238  call os(tamol,trmoy,pizmoy,tamolp,trmoyp,palt,
3239  s phirad,nt,mu,np,rm,gb,rp,
3240  s xlm1)
3241  rorayl=xlm1(-mu,1)/xmus
3242  else
3243  if (palt.le.0.0) then
3244  rorayl=0.
3245  else
3246  call chand(phi,xmuv,xmus,trmoy,rorayl)
3247  endif
3248  endif
3249 c
3250  if (iaer.eq.0) then
3251  romix=rorayl
3252  return
3253  endif
3254 c rayleigh+aerosol=romix,aerosol=roaero reflectance computed
3255 c using sucessive order of scattering method
3256 c 3 cases: satellite,plane,ground
3257  if(palt.gt.0.0) then
3258  rm(-mu)=-xmuv
3259  rm(mu)=xmuv
3260  rm(0)=-xmus
3261 c write(6,*) "input OS",tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt,
3262 c s phirad
3263  call os(tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt,
3264  s phirad,nt,mu,np,rm,gb,rp,
3265  s xlm2)
3266  romix=(xlm2(-mu,1)/xmus)
3267  tamol=0.
3268  tamolp=0.
3269  call os(tamoy,tamol,pizmoy,tamoyp,tamolp,palt,
3270  s phirad,nt,mu,np,rm,gb,rp,
3271  s xlm2)
3272  roaero=(xlm2(-mu,1)/xmus)
3273  else
3274  roaero=0.
3275  romix=0.
3276  endif
3277 c write(6,*) " OS: ",rorayl,roaero,romix
3278  return
3279  end
3280  subroutine bbm
3281  common/sixs_aerbas/ph(10,83)
3282  real phr(10,83)
3283  real ph
3284  integer i,j
3285 c
3286 c model: biomass burning
3287  data ((phr(i,j),j=1,83),i=1,1)/
3288  &0.2150,0.2122,0.2027,0.1928,0.1884,0.1905,0.1952,0.1983,
3289  &0.1980,0.1954,0.1918,0.1874,0.1819,0.1752,0.1680,0.1612,
3290  &0.1553,0.1501,0.1457,0.1417,0.1382,0.1351,0.1326,0.1308,
3291  &0.1296,0.1292,0.1293,0.1299,0.1310,0.1328,0.1353,0.1387,
3292  &0.1429,0.1480,0.1539,0.1606,0.1682,0.1770,0.1870,0.1984,
3293  &0.2115,0.2186,0.2263,0.2432,0.2622,0.2838,0.3082,0.3358,
3294  &0.3671,0.4024,0.4423,0.4875,0.5386,0.5968,0.6630,0.7387,
3295  &0.8253,0.9247,1.0387,1.1695,1.3192,1.4909,1.6883,1.9162,
3296  &2.1797,2.4841,2.8350,3.2382,3.7008,4.2315,4.8393,5.5328,
3297  &6.3184,7.2028,8.1966,9.3190,10.591,12.016,13.541,15.036,
3298  &16.295,17.092,17.290/
3299  data ((phr(i,j),j=1,83),i=2,2)/
3300  &0.2180,0.2160,0.2091,0.2007,0.1951,0.1943,0.1972,0.2005,
3301  &0.2013,0.1986,0.1934,0.1874,0.1819,0.1771,0.1724,0.1673,
3302  &0.1619,0.1565,0.1518,0.1480,0.1449,0.1426,0.1408,0.1395,
3303  &0.1387,0.1383,0.1385,0.1392,0.1406,0.1427,0.1456,0.1492,
3304  &0.1535,0.1585,0.1644,0.1713,0.1793,0.1887,0.1995,0.2119,
3305  &0.2261,0.2339,0.2421,0.2601,0.2803,0.3029,0.3284,0.3571,
3306  &0.3896,0.4266,0.4687,0.5166,0.5710,0.6328,0.7029,0.7826,
3307  &0.8733,0.9769,1.0955,1.2314,1.3869,1.5649,1.7685,2.0010,
3308  &2.2665,2.5691,2.9134,3.3049,3.7496,4.2547,4.8268,5.4728,
3309  &6.1989,7.0122,7.9194,8.9236,10.016,11.166,12.309,13.350,
3310  &14.175,14.677,14.799/
3311  data ((phr(i,j),j=1,83),i=3,3)/
3312  &0.2171,0.2154,0.2091,0.2012,0.1955,0.1939,0.1960,0.1992,
3313  &0.2006,0.1987,0.1940,0.1879,0.1820,0.1770,0.1727,0.1684,
3314  &0.1638,0.1590,0.1544,0.1504,0.1473,0.1450,0.1433,0.1422,
3315  &0.1416,0.1414,0.1418,0.1426,0.1439,0.1459,0.1486,0.1522,
3316  &0.1566,0.1619,0.1681,0.1752,0.1835,0.1930,0.2039,0.2163,
3317  &0.2305,0.2383,0.2466,0.2650,0.2857,0.3090,0.3352,0.3647,
3318  &0.3981,0.4358,0.4785,0.5269,0.5816,0.6437,0.7143,0.7949,
3319  &0.8870,0.9923,1.1126,1.2501,1.4072,1.5866,1.7913,2.0244,
3320  &2.2894,2.5902,2.9315,3.3191,3.7594,4.2591,4.8242,5.4598,
3321  &6.1705,6.9612,7.8359,8.7939,9.8227,10.889,11.934,12.873,
3322  &13.609,14.053,14.161/
3323  data ((phr(i,j),j=1,83),i=4,4)/
3324  &0.2183,0.2168,0.2113,0.2040,0.1981,0.1956,0.1966,0.1992,
3325  &0.2011,0.2003,0.1965,0.1907,0.1843,0.1786,0.1740,0.1701,
3326  &0.1664,0.1624,0.1583,0.1543,0.1510,0.1484,0.1466,0.1454,
3327  &0.1448,0.1447,0.1451,0.1461,0.1476,0.1497,0.1525,0.1560,
3328  &0.1605,0.1660,0.1725,0.1800,0.1886,0.1984,0.2095,0.2221,
3329  &0.2364,0.2442,0.2526,0.2710,0.2920,0.3158,0.3429,0.3735,
3330  &0.4081,0.4469,0.4906,0.5399,0.5957,0.6591,0.7311,0.8132,
3331  &0.9068,1.0134,1.1350,1.2737,1.4317,1.6116,1.8158,2.0475,
3332  &2.3101,2.6080,2.9466,3.3317,3.7694,4.2645,4.8209,5.4417,
3333  &6.1298,6.8888,7.7208,8.6227,9.5794,10.558,11.502,12.339,
3334  &12.989,13.377,13.471/
3335  data ((phr(i,j),j=1,83),i=5,5)/
3336  &0.2249,0.2239,0.2197,0.2137,0.2078,0.2036,0.2019,0.2022,
3337  &0.2034,0.2038,0.2022,0.1985,0.1929,0.1865,0.1803,0.1751,
3338  &0.1711,0.1679,0.1651,0.1624,0.1597,0.1571,0.1549,0.1533,
3339  &0.1525,0.1525,0.1532,0.1545,0.1564,0.1589,0.1622,0.1662,
3340  &0.1710,0.1767,0.1832,0.1907,0.1995,0.2097,0.2215,0.2351,
3341  &0.2505,0.2589,0.2679,0.2874,0.3094,0.3341,0.3621,0.3936,
3342  &0.4294,0.4698,0.5157,0.5676,0.6266,0.6934,0.7691,0.8549,
3343  &0.9521,1.0619,1.1858,1.3254,1.4828,1.6604,1.8614,2.0895,
3344  &2.3492,2.6448,2.9802,3.3587,3.7823,4.2529,4.7729,5.3459,
3345  &5.9763,6.6683,7.4225,8.2312,9.0749,9.9191,10.715,11.405,
3346  &11.931,12.241,12.316/
3347  data ((phr(i,j),j=1,83),i=6,6)/
3348  &0.2268,0.2259,0.2225,0.2173,0.2117,0.2070,0.2041,0.2029,
3349  &0.2031,0.2034,0.2029,0.2008,0.1970,0.1919,0.1861,0.1806,
3350  &0.1758,0.1721,0.1693,0.1673,0.1655,0.1638,0.1622,0.1607,
3351  &0.1597,0.1593,0.1597,0.1609,0.1628,0.1654,0.1687,0.1728,
3352  &0.1778,0.1838,0.1908,0.1990,0.2083,0.2189,0.2309,0.2446,
3353  &0.2602,0.2687,0.2779,0.2981,0.3210,0.3470,0.3763,0.4093,
3354  &0.4464,0.4883,0.5354,0.5887,0.6488,0.7166,0.7931,0.8793,
3355  &0.9763,1.0854,1.2083,1.3469,1.5037,1.6817,1.8840,2.1140,
3356  &2.3747,2.6685,2.9974,3.3632,3.7679,4.2147,4.7080,5.2537,
3357  &5.8571,6.5215,7.2440,8.0132,8.8062,9.5882,10.315,10.936,
3358  &11.403,11.678,11.743/
3359  data ((phr(i,j),j=1,83),i=7,7)/
3360  &0.2427,0.2421,0.2399,0.2362,0.2317,0.2269,0.2224,0.2187,
3361  &0.2159,0.2139,0.2124,0.2110,0.2094,0.2072,0.2041,0.2004,
3362  &0.1962,0.1917,0.1875,0.1839,0.1810,0.1790,0.1779,0.1775,
3363  &0.1776,0.1782,0.1792,0.1805,0.1822,0.1846,0.1877,0.1917,
3364  &0.1968,0.2031,0.2106,0.2194,0.2295,0.2412,0.2545,0.2697,
3365  &0.2869,0.2963,0.3063,0.3284,0.3532,0.3812,0.4125,0.4476,
3366  &0.4868,0.5305,0.5793,0.6339,0.6951,0.7639,0.8414,0.9288,
3367  &1.0277,1.1395,1.2655,1.4074,1.5662,1.7433,1.9398,2.1574,
3368  &2.3979,2.6641,2.9597,3.2895,3.6589,4.0736,4.5385,5.0562,
3369  &5.6261,6.2424,6.8937,7.5622,8.2243,8.8516,9.4132,9.8788,
3370  &10.221,10.418,10.465/
3371  data ((phr(i,j),j=1,83),i=8,8)/
3372  &0.3408,0.3406,0.3396,0.3380,0.3356,0.3327,0.3292,0.3253,
3373  &0.3210,0.3165,0.3119,0.3072,0.3026,0.2981,0.2939,0.2898,
3374  &0.2861,0.2827,0.2797,0.2770,0.2747,0.2728,0.2712,0.2701,
3375  &0.2693,0.2690,0.2693,0.2700,0.2715,0.2737,0.2768,0.2808,
3376  &0.2861,0.2926,0.3005,0.3101,0.3214,0.3346,0.3499,0.3675,
3377  &0.3875,0.3984,0.4100,0.4354,0.4636,0.4951,0.5300,0.5686,
3378  &0.6114,0.6588,0.7114,0.7697,0.8346,0.9068,0.9874,1.0773,
3379  &1.1778,1.2898,1.4147,1.5535,1.7072,1.8766,2.0625,2.2649,
3380  &2.4840,2.7191,2.9691,3.2325,3.5070,3.7899,4.0777,4.3667,
3381  &4.6524,4.9302,5.1951,5.4422,5.6667,5.8638,6.0293,6.1597,
3382  &6.2518,6.3038,6.3160/
3383  data ((phr(i,j),j=1,83),i=9,9)/
3384  &0.4735,0.4733,0.4725,0.4711,0.4690,0.4664,0.4632,0.4596,
3385  &0.4554,0.4507,0.4457,0.4404,0.4347,0.4289,0.4229,0.4168,
3386  &0.4106,0.4046,0.3987,0.3930,0.3876,0.3825,0.3779,0.3738,
3387  &0.3704,0.3676,0.3656,0.3646,0.3645,0.3655,0.3677,0.3712,
3388  &0.3762,0.3827,0.3910,0.4011,0.4134,0.4278,0.4447,0.4643,
3389  &0.4868,0.4992,0.5124,0.5414,0.5742,0.6109,0.6519,0.6974,
3390  &0.7479,0.8036,0.8648,0.9317,1.0047,1.0838,1.1694,1.2615,
3391  &1.3601,1.4653,1.5768,1.6946,1.8182,1.9474,2.0814,2.2197,
3392  &2.3614,2.5057,2.6516,2.7980,2.9435,3.0870,3.2271,3.3623,
3393  &3.4914,3.6129,3.7254,3.8277,3.9184,3.9966,4.0611,4.1113,
3394  &4.1465,4.1662,4.1709/
3395  data ((phr(i,j),j=1,83),i=10,10)/
3396  &0.7907,0.7905,0.7895,0.7878,0.7852,0.7820,0.7780,0.7733,
3397  &0.7679,0.7619,0.7553,0.7481,0.7405,0.7324,0.7239,0.7151,
3398  &0.7061,0.6968,0.6875,0.6782,0.6690,0.6599,0.6512,0.6428,
3399  &0.6349,0.6276,0.6211,0.6154,0.6107,0.6071,0.6047,0.6037,
3400  &0.6042,0.6063,0.6102,0.6160,0.6239,0.6339,0.6462,0.6609,
3401  &0.6782,0.6878,0.6981,0.7207,0.7461,0.7743,0.8055,0.8396,
3402  &0.8768,0.9168,0.9599,1.0058,1.0545,1.1060,1.1601,1.2166,
3403  &1.2753,1.3362,1.3988,1.4630,1.5284,1.5948,1.6618,1.7290,
3404  &1.7962,1.8627,1.9284,1.9927,2.0553,2.1156,2.1734,2.2281,
3405  &2.2795,2.3271,2.3705,2.4095,2.4438,2.4729,2.4969,2.5154,
3406  &2.5283,2.5355,2.5372/
3407  do 1 i=1,10
3408  do 1 j=1,83
3409  ph(i,j)=phr(i,j)
3410  1 continue
3411  return
3412  end
3413  subroutine bdm
3414  common/sixs_aerbas/ph(10,83)
3415  real phr(10,83)
3416  real ph
3417  integer i,j
3418 c
3419 c model:background desert
3420  data ((phr(i,j),j=1,83),i=1,1)/
3421  &0.8352,0.8057,0.7377,0.6569,0.5760,0.5032,0.4427,0.3969,
3422  &0.3646,0.3385,0.3125,0.2863,0.2611,0.2380,0.2175,0.1998,
3423  &0.1848,0.1722,0.1619,0.1536,0.1469,0.1416,0.1376,0.1347,
3424  &0.1329,0.1319,0.1319,0.1327,0.1343,0.1366,0.1397,0.1437,
3425  &0.1485,0.1541,0.1607,0.1682,0.1768,0.1865,0.1974,0.2097,
3426  &0.2235,0.2309,0.2388,0.2559,0.2749,0.2960,0.3196,0.3459,
3427  &0.3750,0.4073,0.4432,0.4831,0.5276,0.5774,0.6331,0.6954,
3428  &0.7652,0.8433,0.9308,1.0291,1.1399,1.2648,1.4060,1.5661,
3429  &1.7479,1.9552,2.1925,2.4657,2.7822,3.1529,3.5921,4.1201,
3430  &4.7671,5.5787,6.6249,8.0218,9.9742,12.864,17.461,25.540,
3431  &42.106,87.294,183.39/
3432  data ((phr(i,j),j=1,83),i=2,2)/
3433  &0.8002,0.7733,0.7063,0.6273,0.5489,0.4793,0.4227,0.3810,
3434  &0.3524,0.3297,0.3071,0.2839,0.2611,0.2399,0.2207,0.2039,
3435  &0.1895,0.1773,0.1672,0.1590,0.1523,0.1471,0.1431,0.1401,
3436  &0.1382,0.1373,0.1372,0.1380,0.1396,0.1419,0.1451,0.1490,
3437  &0.1539,0.1596,0.1663,0.1739,0.1826,0.1925,0.2036,0.2161,
3438  &0.2301,0.2377,0.2458,0.2632,0.2826,0.3042,0.3284,0.3553,
3439  &0.3852,0.4184,0.4553,0.4964,0.5424,0.5938,0.6514,0.7159,
3440  &0.7882,0.8693,0.9603,1.0626,1.1779,1.3081,1.4554,1.6225,
3441  &1.8124,2.0287,2.2763,2.5611,2.8904,3.2747,3.7281,4.2698,
3442  &4.9281,5.7448,6.7836,8.1481,10.017,12.714,16.878,23.920,
3443  &37.639,72.434,130.26/
3444  data ((phr(i,j),j=1,83),i=3,3)/
3445  &0.7899,0.7637,0.6974,0.6190,0.5414,0.4728,0.4173,0.3766,
3446  &0.3489,0.3271,0.3054,0.2830,0.2609,0.2402,0.2214,0.2048,
3447  &0.1906,0.1786,0.1685,0.1603,0.1537,0.1485,0.1445,0.1415,
3448  &0.1396,0.1387,0.1386,0.1394,0.1409,0.1433,0.1464,0.1504,
3449  &0.1553,0.1610,0.1677,0.1754,0.1841,0.1940,0.2052,0.2178,
3450  &0.2319,0.2395,0.2476,0.2651,0.2846,0.3064,0.3307,0.3578,
3451  &0.3879,0.4214,0.4585,0.5000,0.5464,0.5982,0.6563,0.7215,
3452  &0.7944,0.8763,0.9682,1.0715,1.1881,1.3197,1.4685,1.6375,
3453  &1.8294,2.0481,2.2983,2.5859,2.9183,3.3060,3.7626,4.3073,
3454  &4.9677,5.7846,6.8200,8.1736,10.017,12.661,16.709,23.484,
3455  &36.489,68.980,119.09/
3456  data ((phr(i,j),j=1,83),i=4,4)/
3457  &0.7770,0.7516,0.6862,0.6087,0.5323,0.4648,0.4106,0.3713,
3458  &0.3447,0.3239,0.3032,0.2817,0.2604,0.2403,0.2220,0.2058,
3459  &0.1918,0.1800,0.1700,0.1619,0.1553,0.1501,0.1461,0.1432,
3460  &0.1413,0.1403,0.1402,0.1410,0.1426,0.1449,0.1481,0.1521,
3461  &0.1570,0.1628,0.1695,0.1772,0.1860,0.1959,0.2072,0.2199,
3462  &0.2340,0.2417,0.2498,0.2675,0.2871,0.3091,0.3336,0.3608,
3463  &0.3912,0.4250,0.4625,0.5044,0.5512,0.6036,0.6623,0.7282,
3464  &0.8019,0.8848,0.9777,1.0823,1.2003,1.3336,1.4844,1.6555,
3465  &1.8498,2.0712,2.3245,2.6155,2.9515,3.3429,3.8033,4.3511,
3466  &5.0134,5.8298,6.8600,8.1995,10.012,12.589,16.495,22.954,
3467  &35.131,65.032,107.60/
3468  data ((phr(i,j),j=1,83),i=5,5)/
3469  &0.7483,0.7247,0.6618,0.5867,0.5127,0.4480,0.3967,0.3601,
3470  &0.3357,0.3169,0.2982,0.2787,0.2590,0.2403,0.2230,0.2076,
3471  &0.1942,0.1827,0.1730,0.1651,0.1586,0.1535,0.1495,0.1466,
3472  &0.1447,0.1437,0.1437,0.1445,0.1460,0.1484,0.1516,0.1557,
3473  &0.1606,0.1664,0.1732,0.1810,0.1899,0.2000,0.2114,0.2242,
3474  &0.2386,0.2464,0.2546,0.2725,0.2925,0.3147,0.3396,0.3674,
3475  &0.3983,0.4327,0.4710,0.5138,0.5616,0.6151,0.6752,0.7425,
3476  &0.8180,0.9029,0.9982,1.1054,1.2264,1.3631,1.5178,1.6933,
3477  &1.8926,2.1196,2.3789,2.6765,3.0196,3.4181,3.8851,4.4383,
3478  &5.1031,5.9162,6.9324,8.2384,9.9800,12.414,16.024,21.8313,
3479  &32.417,57.406,86.131/
3480  data ((phr(i,j),j=1,83),i=6,6)/
3481  &0.7290,0.7065,0.6456,0.5721,0.5001,0.4373,0.3879,0.3528,
3482  &0.3298,0.3122,0.2948,0.2764,0.2579,0.2400,0.2234,0.2085,
3483  &0.1955,0.1843,0.1748,0.1670,0.1606,0.1555,0.1516,0.1488,
3484  &0.1469,0.1459,0.1459,0.1467,0.1483,0.1507,0.1539,0.1579,
3485  &0.1629,0.1688,0.1756,0.1835,0.1924,0.2026,0.2141,0.2270,
3486  &0.2415,0.2494,0.2577,0.2758,0.2959,0.3185,0.3436,0.3717,
3487  &0.4030,0.4378,0.4766,0.5199,0.5684,0.6227,0.6836,0.7519,
3488  &0.8285,0.9146,1.0114,1.1203,1.2432,1.3821,1.5392,1.7174,
3489  &1.9197,2.1501,2.4131,2.7146,3.0617,3.4642,3.9347,4.4902,
3490  &5.1552,5.9644,6.9694,8.2514,9.9446,12.284,15.706,21.119,
3491  &30.763,52.922,75.133/
3492  data ((phr(i,j),j=1,83),i=7,7)/
3493  &0.6834,0.6633,0.6079,0.5390,0.4716,0.4134,0.3682,0.3368,
3494  &0.3165,0.3014,0.2865,0.2708,0.2546,0.2387,0.2237,0.2101,
3495  &0.1980,0.1875,0.1786,0.1711,0.1650,0.1601,0.1564,0.1536,
3496  &0.1518,0.1509,0.1509,0.1517,0.1534,0.1558,0.1591,0.1632,
3497  &0.1683,0.1742,0.1812,0.1892,0.1983,0.2087,0.2204,0.2337,
3498  &0.2485,0.2565,0.2650,0.2835,0.3042,0.3273,0.3531,0.3819,
3499  &0.4140,0.4499,0.4898,0.5345,0.5844,0.6405,0.7033,0.7739,
3500  &0.8531,0.9420,1.0421,1.1547,1.2818,1.4253,1.5877,1.7716,
3501  &1.9804,2.2176,2.4880,2.7971,3.1520,3.5615,4.0374,4.5953,
3502  &5.2568,6.0522,7.0261,8.2465,9.8238,11.947,14.951,19.512,
3503  &27.207,43.691,55.647/
3504  data ((phr(i,j),j=1,83),i=8,8)/
3505  &0.5664,0.5524,0.5105,0.4593,0.4056,0.3604,0.3252,0.3017,
3506  &0.2868,0.2764,0.2666,0.2562,0.2452,0.2340,0.2231,0.2127,
3507  &0.2033,0.1949,0.1876,0.1814,0.1763,0.1721,0.1689,0.1665,
3508  &0.1651,0.1644,0.1647,0.1657,0.1675,0.1702,0.1737,0.1781,
3509  &0.1835,0.1898,0.1972,0.2056,0.2153,0.2264,0.2388,0.2529,
3510  &0.2687,0.2773,0.2864,0.3062,0.3284,0.3531,0.3808,0.4118,
3511  &0.4464,0.4850,0.5281,0.5763,0.6303,0.6908,0.7586,0.8347,
3512  &0.9201,1.0159,1.1236,1.2446,1.3810,1.5344,1.7076,1.9029,
3513  &2.1236,2.3730,2.6551,2.9753,3.3383,3.7523,4.2252,4.7683,
3514  &5.3971,6.1289,6.9937,8.0270,9.2901,10.873,12.948,15.760,
3515  &20.227,26.155,28.327/
3516  data ((phr(i,j),j=1,83),i=9,9)/
3517  &0.5017,0.4916,0.4574,0.4166,0.3755,0.3366,0.3067,0.2874,
3518  &0.2748,0.2660,0.2585,0.2504,0.2418,0.2329,0.2241,0.2156,
3519  &0.2078,0.2007,0.1945,0.1891,0.1846,0.1810,0.1781,0.1761,
3520  &0.1750,0.1746,0.1750,0.1762,0.1782,0.1810,0.1848,0.1894,
3521  &0.1950,0.2016,0.2093,0.2181,0.2283,0.2398,0.2528,0.2676,
3522  &0.2841,0.2931,0.3026,0.3234,0.3466,0.3726,0.4016,0.4341,
3523  &0.4704,0.5108,0.5560,0.6065,0.6630,0.7261,0.7970,0.8761,
3524  &0.9649,1.0644,1.1759,1.3009,1.4415,1.5992,1.7762,1.9755,
3525  &2.1997,2.4512,2.7345,3.0541,3.4136,3.8188,4.2785,4.7998,
3526  &5.3909,6.0685,6.8504,7.7572,8.8313,10.118,11.724,13.933,
3527  &16.806,19.370,20.119/
3528  data ((phr(i,j),j=1,83),i=10,10)/
3529  &0.4481,0.4411,0.4148,0.3788,0.3444,0.3172,0.2972,0.2822,
3530  &0.2711,0.2632,0.2572,0.2514,0.2450,0.2379,0.2310,0.2245,
3531  &0.2183,0.2126,0.2074,0.2030,0.1993,0.1963,0.1939,0.1923,
3532  &0.1915,0.1914,0.1920,0.1934,0.1957,0.1988,0.2027,0.2076,
3533  &0.2135,0.2206,0.2287,0.2381,0.2488,0.2611,0.2750,0.2906,
3534  &0.3082,0.3178,0.3279,0.3501,0.3748,0.4024,0.4332,0.4677,
3535  &0.5062,0.5491,0.5968,0.6500,0.7094,0.7758,0.8499,0.9325,
3536  &1.0245,1.1273,1.2424,1.3710,1.5144,1.6743,1.8527,2.0524,
3537  &2.2759,2.5253,2.8026,3.1112,3.4553,3.8394,4.2681,4.7465,
3538  &5.2801,5.8742,6.5358,7.2843,8.1602,9.2141,10.458,11.804,
3539  &13.032,13.853,14.061/
3540  do 1 i=1,10
3541  do 1 j=1,83
3542  ph(i,j)=phr(i,j)
3543  1 continue
3544  return
3545  end
3546  subroutine chand (xphi,xmuv,xmus,xtau
3547  s ,xrray)
3548 c input parameters: xphi,xmus,xmuv,xtau
3549 c xphi: azimuthal difference between sun and observation (xphi=0,
3550 c in backscattering) and expressed in degree (0.:360.)
3551 c xmus: cosine of the sun zenith angle
3552 c xmuv: cosine of the observation zenith angle
3553 c xtau: molecular optical depth
3554 c output parameter: xrray : molecular reflectance (0.:1.)
3555 c constant : xdep: depolarization factor (0.0279)
3556  real xdep,pl(10)
3557  real fs0,fs1,fs2
3558  real as0(10),as1(2),as2(2)
3559  real xphi,xmus,fac,xmuv,xtau,xrray,pi,phios,xcosf1,xcosf2
3560  real xcosf3,xbeta2,xfd,xph1,xph2,xph3,xitm, xp1, xp2, xp3
3561  real cfonc1,cfonc2,cfonc3,xlntau,xitot1,xitot2,xitot3
3562  integer i
3563  data (as0(i),i=1,10) /.33243832,-6.777104e-02,.16285370
3564  s ,1.577425e-03,-.30924818,-1.240906e-02,-.10324388
3565  s ,3.241678e-02,.11493334,-3.503695e-02/
3566  data (as1(i),i=1,2) /.19666292, -5.439061e-02/
3567  data (as2(i),i=1,2) /.14545937,-2.910845e-02/
3568  pi=3.1415927
3569  fac=pi/180.
3570  phios=180.-xphi
3571  xcosf1=1.
3572  xcosf2=cos(phios*fac)
3573  xcosf3=cos(2*phios*fac)
3574  xbeta2=0.5
3575  xdep=0.0279
3576  xfd=xdep/(2-xdep)
3577  xfd=(1-xfd)/(1+2*xfd)
3578  xph1=1+(3*xmus*xmus-1)*(3*xmuv*xmuv-1)*xfd/8.
3579  xph2=-xmus*xmuv*sqrt(1-xmus*xmus)*sqrt(1-xmuv*xmuv)
3580  xph2=xph2*xfd*xbeta2*1.5
3581  xph3=(1-xmus*xmus)*(1-xmuv*xmuv)
3582  xph3=xph3*xfd*xbeta2*0.375
3583  xitm=(1-exp(-xtau*(1/xmus+1/xmuv)))*xmus/(4*(xmus+xmuv))
3584  xp1=xph1*xitm
3585  xp2=xph2*xitm
3586  xp3=xph3*xitm
3587  xitm=(1-exp(-xtau/xmus))*(1-exp(-xtau/xmuv))
3588  cfonc1=xph1*xitm
3589  cfonc2=xph2*xitm
3590  cfonc3=xph3*xitm
3591  xlntau=log(xtau)
3592  pl(1)=1.
3593  pl(2)=xlntau
3594  pl(3)=xmus+xmuv
3595  pl(4)=xlntau*pl(3)
3596  pl(5)=xmus*xmuv
3597  pl(6)=xlntau*pl(5)
3598  pl(7)=xmus*xmus+xmuv*xmuv
3599  pl(8)=xlntau*pl(7)
3600  pl(9)=xmus*xmus*xmuv*xmuv
3601  pl(10)=xlntau*pl(9)
3602  fs0=0.
3603  do i=1,10
3604  fs0=fs0+pl(i)*as0(i)
3605  enddo
3606  fs1=pl(1)*as1(1)+pl(2)*as1(2)
3607  fs2=pl(1)*as2(1)+pl(2)*as2(2)
3608  xitot1=xp1+cfonc1*fs0*xmus
3609  xitot2=xp2+cfonc2*fs1*xmus
3610  xitot3=xp3+cfonc3*fs2*xmus
3611  xrray=xitot1*xcosf1
3612  xrray=xrray+xitot2*xcosf2*2
3613  xrray=xrray+xitot3*xcosf3*2
3614  xrray=xrray/xmus
3615  return
3616  end
3617  subroutine csalbr(xtau,xalb)
3618  real xtau,xalb,fintexp3
3619  xalb=(3*xtau-fintexp3(xtau)*(4+2*xtau)+2*exp(-xtau))
3620  xalb=xalb/(4.+3*xtau)
3621  return
3622  end
3623  real function fintexp3(xtau)
3624  real xx,xtau,fintexp1
3625  xx=(exp(-xtau)*(1.-xtau)+xtau*xtau*fintexp1(xtau))/2.
3626  fintexp3=xx
3627  return
3628  end
3629  real function fintexp1(xtau)
3630 c accuracy 2e-07... for 0<xtau<1
3631  real xx,a(0:5),xtau,xftau
3632  integer i
3633  data (a(i),i=0,5) /-.57721566,0.99999193,-0.24991055,
3634  c 0.05519968,-0.00976004,0.00107857/
3635  xx=a(0)
3636  xftau=1.
3637  do i=1,5
3638  xftau=xftau*xtau
3639  xx=xx+a(i)*xftau
3640  enddo
3641  fintexp1=xx-log(xtau)
3642  return
3643  end
3644  subroutine discom (idatmp,iaer,xmus,xmuv,phi,
3645  a taer55,taer55p,palt,
3646  a phirad,nt,mu,np,rm,gb,rp,
3647  a ftray,xlm1,xlm2)
3648  integer mu,np
3649  real rm(-mu:mu),rp(np),gb(-mu:mu)
3650  real ftray,xlm1(-mu:mu,np),xlm2(-mu:mu,np)
3651  real xmus,xmuv,phi
3652  real taer55,taer55p,palt,phirad,ext,ome,gasym,phase,roatm
3653  real dtdir,dtdif,utdir,utdif,sphal,wldis,trayl,traypl,s
3654  real wlinf,wlsup,phasel,pdgs,cgaus,pha,betal,wl,tray,trayp,taer
3655  real taerp,piza,tamoy,tamoyp,pizmoy,rorayl
3656  real roaero,romix,ddirtt,ddiftt,udirtt,udiftt,sphalbt,ddirtr
3657  real ddiftr,udirtr,udiftr,sphalbr,ddirta,ddifta,udirta,udifta
3658  real sphalba,coeff
3659  integer idatmp,iaer,nt,l,k
3660  common /sixs_aer/ext(10),ome(10),gasym(10),phase(10)
3661  common /sixs_disc/ roatm(3,10),dtdir(3,10),dtdif(3,10),
3662  a utdir(3,10),utdif(3,10),sphal(3,10),wldis(10),trayl(10),
3663  a traypl(10)
3664  common /sixs_ffu/s(1501),wlinf,wlsup
3665  common /sixs_sos/phasel(10,83),cgaus(83),pdgs(83)
3666  common /sixs_trunc/pha(83),betal(0:80)
3667 
3668 c computation of all scattering parameters at wavelength
3669 c discrete values,so we
3670 c can interpolate at any wavelength
3671 
3672  do 50 l=1,10
3673  wl=wldis(l)
3674  if ((wlsup.lt.wldis(1)).and.(l.le.2)) goto 30
3675  if (wlinf.gt.wldis(10).and.(l.ge.9)) goto 30
3676  if ((l.lt.10).and.(wldis(l).lt.wlinf).and.
3677  a (wldis(l+1).lt.wlinf))
3678  a goto 50
3679  if ((l.gt.1).and.(wldis(l).gt.wlsup).and.
3680  a (wldis(l-1).gt.wlsup))
3681  a goto 50
3682 
3683 c computation of rayleigh optical depth at wl
3684 
3685  30 call odrayl(wl,
3686  a tray)
3687 
3688 c plane case discussed here above
3689 
3690  if (idatmp.eq.0.or.idatmp.eq.4) then
3691  if (idatmp.eq.4) trayp=tray
3692  if (idatmp.eq.0) trayp=0.
3693  else
3694  trayp=tray*ftray
3695  endif
3696  trayl(l)=tray
3697  traypl(l)=trayp
3698 
3699 c computation of aerosol optical properties at wl
3700 
3701  taer=taer55*ext(l)/ext(4)
3702  taerp=taer55p*ext(l)/ext(4)
3703  piza=ome(l)
3704 c
3705 c computation of atmospheric reflectances
3706 c rorayl is rayleigh ref
3707 c roaero is aerosol ref
3708 c call plegen to decompose aerosol phase function in Betal
3709  if (iaer.ne.0) then
3710  do k=1,83
3711  pha(k)=phasel(l,k)
3712  enddo
3713  call trunca(coeff)
3714  endif
3715 c write(6,*) 'truncation coefficient ',coeff
3716  tamoy=taer*(1.-piza*coeff)
3717  tamoyp=taerp*(1.-piza*coeff)
3718  pizmoy=piza*(1.-coeff)/(1.-piza*coeff)
3719 c write(6,*) 'tray,trayp,tamoy,tamoyp,pizmoy,piza,taer,taerp',
3720 c S tray,trayp,tamoy,tamoyp,pizmoy,piza,taer,taerp
3721 c do i=0,80
3722 c write(6,'(A5,I2.2,1X,E13.7)') 'betal',i,betal(i)
3723 c enddo
3724 c
3725  call atmref(iaer,tamoy,tray,pizmoy,tamoyp,trayp,palt,
3726  a phi,xmus,xmuv,
3727  s phirad,nt,mu,np,rm,gb,rp,
3728  a rorayl,roaero,romix,xlm1,xlm2)
3729 c write(6,*) 'wl,refrayl,refaero,refmix',wl,rorayl,roaero,romix
3730 c computation of scattering transmitances (direct and diffuse)
3731 c first time for rayleigh ,next total (rayleigh+aerosols)
3732  call scatra (tamoy,tamoyp,tray,trayp,pizmoy,
3733  a palt,nt,mu,rm,gb,xmus,xmuv,
3734  a ddirtt,ddiftt,udirtt,udiftt,sphalbt,
3735  a ddirtr,ddiftr,udirtr,udiftr,sphalbr,
3736  a ddirta,ddifta,udirta,udifta,sphalba)
3737  roatm(1,l)=rorayl
3738  roatm(2,l)=romix
3739  roatm(3,l)=roaero
3740  dtdir(1,l)=ddirtr
3741  dtdif(1,l)=ddiftr
3742  dtdir(2,l)=ddirtt
3743  dtdif(2,l)=ddiftt
3744  dtdir(3,l)=ddirta
3745  dtdif(3,l)=ddifta
3746  utdir(1,l)=udirtr
3747  utdif(1,l)=udiftr
3748  utdir(2,l)=udirtt
3749  utdif(2,l)=udiftt
3750  utdir(3,l)=udirta
3751  utdif(3,l)=udifta
3752  sphal(1,l)=sphalbr
3753  sphal(2,l)=sphalbt
3754  sphal(3,l)=sphalba
3755  50 continue
3756  return
3757  end
3758  subroutine discre(ta,ha,tr,hr,it,nt,yy,dd,ppp2,ppp1,
3759  s zx)
3760  real ta,ha,tr,hr,yy,dd,ppp2,ppp1,zx,dt,ti,y1,y2,y3,x2
3761  real xd,delta,ecart
3762  double precision xx
3763  integer it,nt
3764  if (ha.ge.7.) then
3765  call print_error
3766  s ('check aerosol measurements or plane altitude')
3767  return
3768  endif
3769  if (it.eq.0) then
3770  dt=1.e-17
3771  else
3772  dt=2.*(ta+tr-yy)/(nt-it+1.)
3773  endif
3774  99 dt=dt/2.
3775  ti=yy+dt
3776  y1=ppp2
3777  y3=ppp1
3778  706 y2=(y1+y3)*0.5
3779  xx=-y2/ha
3780  if (xx.lt.-18) then
3781  x2=tr*exp(-y2/hr)
3782  else
3783  x2=ta*dexp(xx)+tr*exp(-y2/hr)
3784  endif
3785  xd=abs(ti-x2)
3786  if(xd.lt.0.00001) go to 705
3787  if(ti-x2) 701,703,703
3788  701 y3=y2
3789  go to 706
3790  703 y1=y2
3791  go to 706
3792  705 zx=y2
3793  delta=1./(1.+ta*hr/tr/ha*exp((zx-ppp1)*(1./hr-1./ha)))
3794  ecart=0
3795  if(dd.ne.0) ecart=abs((dd-delta)/dd)
3796  if((ecart.gt.0.75).and.(it.ne.0)) go to 99
3797  return
3798  end
3799  subroutine dust
3800  common /sixs_aerbas/ ph(10,83)
3801  real phr(10,83),ph
3802  integer i,j
3803 c
3804 c model: dust-like
3805 c
3806  DATA ((phr(i,j),j=1,83),i=01,01) /
3807  *0.2021e+00,0.2079e+00,0.2462e+00,0.2310e+00,0.2069e+00,0.1883e+00,
3808  *0.1750e+00,0.1624e+00,0.1458e+00,0.1241e+00,0.1013e+00,0.8379e-01,
3809  *0.7097e-01,0.6207e-01,0.5595e-01,0.5174e-01,0.4879e-01,0.4675e-01,
3810  *0.4531e-01,0.4435e-01,0.4373e-01,0.4337e-01,0.4324e-01,0.4330e-01,
3811  *0.4353e-01,0.4392e-01,0.4449e-01,0.4522e-01,0.4612e-01,0.4721e-01,
3812  *0.4850e-01,0.5001e-01,0.5177e-01,0.5381e-01,0.5616e-01,0.5885e-01,
3813  *0.6191e-01,0.6540e-01,0.6936e-01,0.7383e-01,0.7889e-01,0.8168e-01,
3814  *0.8459e-01,0.9096e-01,0.9808e-01,0.1060e+00,0.1148e+00,0.1246e+00,
3815  *0.1355e+00,0.1474e+00,0.1605e+00,0.1750e+00,0.1910e+00,0.2088e+00,
3816  *0.2284e+00,0.2501e+00,0.2739e+00,0.3000e+00,0.3284e+00,0.3594e+00,
3817  *0.3935e+00,0.4308e+00,0.4718e+00,0.5172e+00,0.5670e+00,0.6222e+00,
3818  *0.6840e+00,0.7528e+00,0.8308e+00,0.9217e+00,0.1029e+01,0.1159e+01,
3819  *0.1327e+01,0.1553e+01,0.1878e+01,0.2386e+01,0.3253e+01,0.4937e+01,
3820  *0.8737e+01,0.1952e+02,0.6427e+02,0.4929e+03,0.5169e+05/
3821  DATA ((phr(i,j),j=1,83),i=02,02) /
3822  *0.2467e+00,0.2483e+00,0.2871e+00,0.2722e+00,0.2454e+00,0.2231e+00,
3823  *0.2060e+00,0.1900e+00,0.1704e+00,0.1452e+00,0.1186e+00,0.9754e-01,
3824  *0.8182e-01,0.7067e-01,0.6284e-01,0.5734e-01,0.5345e-01,0.5070e-01,
3825  *0.4875e-01,0.4741e-01,0.4651e-01,0.4596e-01,0.4570e-01,0.4569e-01,
3826  *0.4589e-01,0.4631e-01,0.4693e-01,0.4776e-01,0.4879e-01,0.5005e-01,
3827  *0.5153e-01,0.5328e-01,0.5532e-01,0.5768e-01,0.6040e-01,0.6350e-01,
3828  *0.6704e-01,0.7104e-01,0.7559e-01,0.8071e-01,0.8648e-01,0.8967e-01,
3829  *0.9298e-01,0.1002e+00,0.1083e+00,0.1173e+00,0.1273e+00,0.1384e+00,
3830  *0.1507e+00,0.1641e+00,0.1790e+00,0.1954e+00,0.2134e+00,0.2335e+00,
3831  *0.2557e+00,0.2801e+00,0.3070e+00,0.3366e+00,0.3687e+00,0.4039e+00,
3832  *0.4427e+00,0.4850e+00,0.5316e+00,0.5834e+00,0.6402e+00,0.7032e+00,
3833  *0.7738e+00,0.8527e+00,0.9422e+00,0.1047e+01,0.1171e+01,0.1321e+01,
3834  *0.1516e+01,0.1780e+01,0.2160e+01,0.2753e+01,0.3768e+01,0.5728e+01,
3835  *0.1011e+02,0.2231e+02,0.7109e+02,0.5001e+03,0.3548e+05/
3836  DATA ((phr(i,j),j=1,83),i=03,03) /
3837  *0.2599e+00,0.2602e+00,0.2986e+00,0.2838e+00,0.2563e+00,0.2330e+00,
3838  *0.2148e+00,0.1978e+00,0.1774e+00,0.1513e+00,0.1237e+00,0.1017e+00,
3839  *0.8513e-01,0.7333e-01,0.6499e-01,0.5912e-01,0.5494e-01,0.5198e-01,
3840  *0.4986e-01,0.4840e-01,0.4742e-01,0.4681e-01,0.4651e-01,0.4647e-01,
3841  *0.4667e-01,0.4708e-01,0.4772e-01,0.4858e-01,0.4965e-01,0.5094e-01,
3842  *0.5249e-01,0.5430e-01,0.5642e-01,0.5887e-01,0.6169e-01,0.6491e-01,
3843  *0.6858e-01,0.7273e-01,0.7744e-01,0.8274e-01,0.8872e-01,0.9201e-01,
3844  *0.9544e-01,0.1029e+00,0.1113e+00,0.1206e+00,0.1309e+00,0.1424e+00,
3845  *0.1550e+00,0.1689e+00,0.1842e+00,0.2011e+00,0.2198e+00,0.2404e+00,
3846  *0.2633e+00,0.2886e+00,0.3163e+00,0.3468e+00,0.3800e+00,0.4164e+00,
3847  *0.4565e+00,0.5002e+00,0.5485e+00,0.6020e+00,0.6608e+00,0.7261e+00,
3848  *0.7993e+00,0.8810e+00,0.9739e+00,0.1083e+01,0.1211e+01,0.1368e+01,
3849  *0.1571e+01,0.1846e+01,0.2242e+01,0.2860e+01,0.3918e+01,0.5956e+01,
3850  *0.1050e+02,0.2307e+02,0.7281e+02,0.4999e+03,0.3196e+05/
3851  DATA ((phr(i,j),j=1,83),i=04,04) /
3852  *0.2765e+00,0.2752e+00,0.3129e+00,0.2981e+00,0.2697e+00,0.2452e+00,
3853  *0.2256e+00,0.2075e+00,0.1862e+00,0.1589e+00,0.1301e+00,0.1069e+00,
3854  *0.8939e-01,0.7677e-01,0.6780e-01,0.6145e-01,0.5690e-01,0.5366e-01,
3855  *0.5134e-01,0.4973e-01,0.4862e-01,0.4794e-01,0.4758e-01,0.4751e-01,
3856  *0.4769e-01,0.4811e-01,0.4877e-01,0.4965e-01,0.5076e-01,0.5212e-01,
3857  *0.5373e-01,0.5563e-01,0.5784e-01,0.6041e-01,0.6336e-01,0.6672e-01,
3858  *0.7055e-01,0.7488e-01,0.7979e-01,0.8532e-01,0.9155e-01,0.9497e-01,
3859  *0.9854e-01,0.1063e+00,0.1150e+00,0.1247e+00,0.1354e+00,0.1473e+00,
3860  *0.1604e+00,0.1748e+00,0.1907e+00,0.2083e+00,0.2276e+00,0.2491e+00,
3861  *0.2729e+00,0.2990e+00,0.3279e+00,0.3596e+00,0.3941e+00,0.4319e+00,
3862  *0.4735e+00,0.5191e+00,0.5693e+00,0.6251e+00,0.6864e+00,0.7545e+00,
3863  *0.8309e+00,0.9163e+00,0.1013e+01,0.1127e+01,0.1262e+01,0.1426e+01,
3864  *0.1640e+01,0.1928e+01,0.2345e+01,0.2995e+01,0.4106e+01,0.6242e+01,
3865  *0.1098e+02,0.2400e+02,0.7481e+02,0.4984e+03,0.2810e+05/
3866  DATA ((phr(i,j),j=1,83),i=05,05) /
3867  *0.3140e+00,0.3090e+00,0.3440e+00,0.3291e+00,0.2988e+00,0.2716e+00,
3868  *0.2491e+00,0.2285e+00,0.2053e+00,0.1759e+00,0.1447e+00,0.1190e+00,
3869  *0.9926e-01,0.8484e-01,0.7446e-01,0.6700e-01,0.6162e-01,0.5774e-01,
3870  *0.5493e-01,0.5295e-01,0.5158e-01,0.5070e-01,0.5021e-01,0.5005e-01,
3871  *0.5019e-01,0.5060e-01,0.5129e-01,0.5224e-01,0.5344e-01,0.5492e-01,
3872  *0.5668e-01,0.5876e-01,0.6118e-01,0.6400e-01,0.6723e-01,0.7091e-01,
3873  *0.7509e-01,0.7981e-01,0.8516e-01,0.9117e-01,0.9793e-01,0.1016e+00,
3874  *0.1055e+00,0.1140e+00,0.1234e+00,0.1338e+00,0.1454e+00,0.1582e+00,
3875  *0.1724e+00,0.1879e+00,0.2051e+00,0.2241e+00,0.2449e+00,0.2681e+00,
3876  *0.2937e+00,0.3220e+00,0.3531e+00,0.3873e+00,0.4247e+00,0.4656e+00,
3877  *0.5108e+00,0.5603e+00,0.6149e+00,0.6756e+00,0.7425e+00,0.8168e+00,
3878  *0.9003e+00,0.9939e+00,0.1101e+01,0.1226e+01,0.1374e+01,0.1557e+01,
3879  *0.1793e+01,0.2114e+01,0.2577e+01,0.3299e+01,0.4529e+01,0.6879e+01,
3880  *0.1204e+02,0.2596e+02,0.7866e+02,0.4906e+03,0.2124e+05/
3881  DATA ((phr(i,j),j=1,83),i=06,06) /
3882  *0.3397e+00,0.3323e+00,0.3646e+00,0.3493e+00,0.3179e+00,0.2889e+00,
3883  *0.2644e+00,0.2424e+00,0.2181e+00,0.1874e+00,0.1547e+00,0.1274e+00,
3884  *0.1062e+00,0.9063e-01,0.7928e-01,0.7107e-01,0.6509e-01,0.6076e-01,
3885  *0.5761e-01,0.5537e-01,0.5380e-01,0.5278e-01,0.5218e-01,0.5196e-01,
3886  *0.5206e-01,0.5246e-01,0.5317e-01,0.5415e-01,0.5542e-01,0.5697e-01,
3887  *0.5883e-01,0.6103e-01,0.6359e-01,0.6657e-01,0.6998e-01,0.7387e-01,
3888  *0.7829e-01,0.8327e-01,0.8891e-01,0.9524e-01,0.1024e+00,0.1063e+00,
3889  *0.1103e+00,0.1192e+00,0.1291e+00,0.1400e+00,0.1522e+00,0.1656e+00,
3890  *0.1805e+00,0.1968e+00,0.2148e+00,0.2346e+00,0.2565e+00,0.2807e+00,
3891  *0.3076e+00,0.3372e+00,0.3699e+00,0.4058e+00,0.4451e+00,0.4881e+00,
3892  *0.5357e+00,0.5878e+00,0.6454e+00,0.7094e+00,0.7800e+00,0.8586e+00,
3893  *0.9471e+00,0.1046e+01,0.1160e+01,0.1293e+01,0.1451e+01,0.1646e+01,
3894  *0.1899e+01,0.2242e+01,0.2738e+01,0.3509e+01,0.4820e+01,0.7310e+01,
3895  *0.1274e+02,0.2720e+02,0.8080e+02,0.4822e+03,0.1763e+05/
3896  DATA ((phr(i,j),j=1,83),i=07,07) /
3897  *0.3665e+00,0.3585e+00,0.3853e+00,0.3705e+00,0.3386e+00,0.3093e+00,
3898  *0.2869e+00,0.2705e+00,0.2507e+00,0.2187e+00,0.1832e+00,0.1512e+00,
3899  *0.1258e+00,0.1065e+00,0.9217e-01,0.8162e-01,0.7386e-01,0.6812e-01,
3900  *0.6393e-01,0.6088e-01,0.5870e-01,0.5723e-01,0.5631e-01,0.5585e-01,
3901  *0.5579e-01,0.5612e-01,0.5681e-01,0.5783e-01,0.5918e-01,0.6088e-01,
3902  *0.6291e-01,0.6532e-01,0.6815e-01,0.7143e-01,0.7521e-01,0.7951e-01,
3903  *0.8439e-01,0.8988e-01,0.9607e-01,0.1030e+00,0.1108e+00,0.1151e+00,
3904  *0.1196e+00,0.1293e+00,0.1400e+00,0.1520e+00,0.1652e+00,0.1799e+00,
3905  *0.1961e+00,0.2140e+00,0.2338e+00,0.2557e+00,0.2799e+00,0.3069e+00,
3906  *0.3367e+00,0.3696e+00,0.4060e+00,0.4461e+00,0.4901e+00,0.5388e+00,
3907  *0.5927e+00,0.6520e+00,0.7180e+00,0.7913e+00,0.8725e+00,0.9634e+00,
3908  *0.1066e+01,0.1181e+01,0.1314e+01,0.1469e+01,0.1655e+01,0.1885e+01,
3909  *0.2183e+01,0.2586e+01,0.3166e+01,0.4061e+01,0.5568e+01,0.8386e+01,
3910  *0.1440e+02,0.2992e+02,0.8452e+02,0.4537e+03,0.1132e+05/
3911  DATA ((phr(i,j),j=1,83),i=08,08) /
3912  *0.2248e+00,0.2041e+00,0.2013e+00,0.2015e+00,0.2038e+00,0.2142e+00,
3913  *0.2218e+00,0.2177e+00,0.2078e+00,0.1973e+00,0.1876e+00,0.1779e+00,
3914  *0.1666e+00,0.1530e+00,0.1377e+00,0.1221e+00,0.1078e+00,0.9531e-01,
3915  *0.8504e-01,0.7686e-01,0.7052e-01,0.6573e-01,0.6219e-01,0.5966e-01,
3916  *0.5794e-01,0.5689e-01,0.5645e-01,0.5656e-01,0.5718e-01,0.5825e-01,
3917  *0.5974e-01,0.6159e-01,0.6382e-01,0.6647e-01,0.6955e-01,0.7314e-01,
3918  *0.7723e-01,0.8187e-01,0.8711e-01,0.9302e-01,0.9976e-01,0.1035e+00,
3919  *0.1075e+00,0.1163e+00,0.1263e+00,0.1377e+00,0.1507e+00,0.1653e+00,
3920  *0.1819e+00,0.2008e+00,0.2222e+00,0.2467e+00,0.2745e+00,0.3060e+00,
3921  *0.3418e+00,0.3822e+00,0.4279e+00,0.4800e+00,0.5391e+00,0.6066e+00,
3922  *0.6838e+00,0.7715e+00,0.8718e+00,0.9864e+00,0.1117e+01,0.1268e+01,
3923  *0.1442e+01,0.1643e+01,0.1880e+01,0.2160e+01,0.2496e+01,0.2906e+01,
3924  *0.3423e+01,0.4095e+01,0.5014e+01,0.6356e+01,0.8465e+01,0.1211e+02,
3925  *0.1924e+02,0.3569e+02,0.8510e+02,0.3357e+03,0.3290e+04/
3926  DATA ((phr(i,j),j=1,83),i=09,09) /
3927  *0.8649e-01,0.6705e-01,0.5195e-01,0.7001e-01,0.7008e-01,0.6002e-01,
3928  *0.5176e-01,0.4616e-01,0.4241e-01,0.3977e-01,0.3795e-01,0.3668e-01,
3929  *0.3583e-01,0.3535e-01,0.3514e-01,0.3524e-01,0.3565e-01,0.3638e-01,
3930  *0.3751e-01,0.3892e-01,0.4055e-01,0.4217e-01,0.4354e-01,0.4447e-01,
3931  *0.4473e-01,0.4432e-01,0.4334e-01,0.4196e-01,0.4043e-01,0.3895e-01,
3932  *0.3767e-01,0.3668e-01,0.3599e-01,0.3567e-01,0.3568e-01,0.3603e-01,
3933  *0.3675e-01,0.3782e-01,0.3929e-01,0.4119e-01,0.4354e-01,0.4489e-01,
3934  *0.4638e-01,0.4977e-01,0.5377e-01,0.5848e-01,0.6402e-01,0.7052e-01,
3935  *0.7819e-01,0.8720e-01,0.9780e-01,0.1103e+00,0.1250e+00,0.1423e+00,
3936  *0.1629e+00,0.1872e+00,0.2164e+00,0.2514e+00,0.2934e+00,0.3442e+00,
3937  *0.4055e+00,0.4799e+00,0.5709e+00,0.6824e+00,0.8200e+00,0.9912e+00,
3938  *0.1205e+01,0.1474e+01,0.1814e+01,0.2247e+01,0.2801e+01,0.3520e+01,
3939  *0.4460e+01,0.5710e+01,0.7406e+01,0.9765e+01,0.1318e+02,0.1847e+02,
3940  *0.2749e+02,0.4547e+02,0.9155e+02,0.2798e+03,0.1582e+04/
3941  DATA ((phr(i,j),j=1,83),i=10,10) /
3942  *0.9344e-01,0.8261e-01,0.6680e-01,0.7550e-01,0.8962e-01,0.9095e-01,
3943  *0.8469e-01,0.7755e-01,0.7170e-01,0.6726e-01,0.6401e-01,0.6173e-01,
3944  *0.6034e-01,0.5974e-01,0.5979e-01,0.6028e-01,0.6096e-01,0.6155e-01,
3945  *0.6179e-01,0.6151e-01,0.6067e-01,0.5928e-01,0.5752e-01,0.5554e-01,
3946  *0.5354e-01,0.5165e-01,0.4997e-01,0.4858e-01,0.4752e-01,0.4683e-01,
3947  *0.4651e-01,0.4657e-01,0.4701e-01,0.4781e-01,0.4897e-01,0.5053e-01,
3948  *0.5250e-01,0.5493e-01,0.5787e-01,0.6137e-01,0.6550e-01,0.6782e-01,
3949  *0.7033e-01,0.7593e-01,0.8242e-01,0.8992e-01,0.9860e-01,0.1087e+00,
3950  *0.1203e+00,0.1339e+00,0.1497e+00,0.1682e+00,0.1896e+00,0.2147e+00,
3951  *0.2441e+00,0.2786e+00,0.3193e+00,0.3675e+00,0.4248e+00,0.4931e+00,
3952  *0.5747e+00,0.6726e+00,0.7902e+00,0.9324e+00,0.1105e+01,0.1316e+01,
3953  *0.1575e+01,0.1895e+01,0.2292e+01,0.2787e+01,0.3407e+01,0.4192e+01,
3954  *0.5195e+01,0.6498e+01,0.8221e+01,0.1057e+02,0.1389e+02,0.1886e+02,
3955  *0.2699e+02,0.4205e+02,0.7598e+02,0.1847e+03,0.5926e+03/
3956  do 1 i=1,10
3957  do 1 j=1,83
3958  ph(i,j)=phr(i,j)
3959  1 continue
3960  return
3961  end
3962  subroutine enviro (difr,difa,r,palt,xmuv,
3963  a fra,fae,fr)
3964  real difr, difa, r, palt
3965  real fae,fra,fr,fae0,fra0,xmuv,xlnv,a0,b0,a1,b1
3966  real zmin,zmax,xcfr1,xcfr2,xcfa1,xcfa2,xcfa3
3967  real alt(16),cfr1(16),cfr2(16),cfa1(16),cfa2(16),cfa3(16)
3968  integer i
3969  data (alt(i),i=1,16) /0.5,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,
3970  s 10.0,12.0,14.0,16.0,18.0,20.0,60.0/
3971  data (cfr1(i),i=1,16) /0.730,0.710,0.656,0.606,0.560,0.516,0.473,
3972  s 0.433,0.395,0.323,0.258,0.209,0.171,0.142,0.122,0.070/
3973  data (cfr2(i),i=1,16) /2.8,1.51,0.845,0.634,0.524,0.465,0.429,
3974  s 0.405,0.390,0.386,0.409,0.445,0.488,0.545,0.608,0.868/
3975  data (cfa1(i),i=1,16) /0.239,0.396,0.588,0.626,0.612,0.505,0.454,
3976  s 0.448,0.444,0.445,0.444,0.448,0.448,0.448,0.448,0.448/
3977  data (cfa2(i),i=1,16) /1.40,1.20,1.02,0.86,0.74,0.56,0.46,0.42,
3978  s 0.38,0.34,0.3,0.28,0.27,0.27,0.27,0.27/
3979  data (cfa3(i),i=1,16) /9.17,6.26,5.48,5.16,4.74,3.65,3.24,3.15,
3980  s 3.07,2.97,2.88,2.83,2.83,2.83,2.83,2.83/
3981 c
3982 c calculation of the environmental function for
3983 c rayleigh and aerosols contribution.
3984 c
3985 c this calculation have been done for nadir observation
3986 c and are corrected of the effect of the view zenith angle.
3987 c
3988  a0=1.3347
3989  b0=0.57757
3990  a1=-1.479
3991  b1=-1.5275
3992 
3993  if (palt.ge.60.) then
3994  fae0=1-0.448*exp(-r*0.27)-0.552*exp(-r*2.83)
3995  fra0=1-0.930*exp(-r*0.080)-0.070*exp(-r*1.100)
3996  else
3997  i=0
3998  10 i=i+1
3999  if (palt.ge.alt(i)) goto 10
4000  if ((i.gt.1).and.(i.lt.16)) then
4001  zmin=alt(i-1)
4002  zmax=alt(i)
4003  xcfr1=cfr1(i-1)+(cfr1(i)-cfr1(i-1))*(zmax-palt)/(zmax-zmin)
4004  xcfr2=cfr2(i-1)+(cfr2(i)-cfr2(i-1))*(zmax-palt)/(zmax-zmin)
4005  xcfa1=cfa1(i-1)+(cfa1(i)-cfa1(i-1))*(zmax-palt)/(zmax-zmin)
4006  xcfa2=cfa2(i-1)+(cfa2(i)-cfa2(i-1))*(zmax-palt)/(zmax-zmin)
4007  xcfa3=cfa3(i-1)+(cfa3(i)-cfa3(i-1))*(zmax-palt)/(zmax-zmin)
4008  endif
4009  if (i.eq.1) then
4010  xcfr1=cfr1(1)
4011  xcfr2=cfr2(1)
4012  xcfa1=cfa1(1)
4013  xcfa2=cfa2(1)
4014  xcfa3=cfa3(1)
4015  endif
4016  fra0=1.-xcfr1*exp(-r*xcfr2)-(1.-xcfr1)*exp(-r*0.08)
4017  fae0=1.-xcfa1*exp(-r*xcfa2)-(1.-xcfa1)*exp(-r*xcfa3)
4018  endif
4019 c correction of the effect of the view zenith angle
4020  xlnv=log(xmuv)
4021  fra=fra0*(xlnv*(1-fra0)+1)
4022  fae=fae0*((1+a0*xlnv+b0*xlnv*xlnv)+fae0*(a1*xlnv+b1*xlnv*xlnv)+
4023  sfae0*fae0*((-a1-a0)*xlnv+(-b1-b0)*xlnv*xlnv))
4024 c
4025  if ((difa+difr).gt.1.e-03) then
4026  fr=(fae*difa+fra*difr)/(difa+difr)
4027  else
4028  fr=1.
4029  endif
4030  return
4031  end
4032  subroutine equivwl(iinf,isup,step,
4033  s wlmoy)
4034  common /sixs_ffu/s(1501),wlinf,wlsup
4035  real step,wlmoy,s,wlinf,wlsup,seb,wlwave,sbor,wl,swl,coef
4036  integer iinf,isup,l
4037  seb=0.
4038  wlwave=0.
4039  do 50 l=iinf,isup
4040  sbor=s(l)
4041  if(l.eq.iinf.or.l.eq.isup) sbor=sbor*0.5
4042  wl=.25+(l-1)*step
4043 C--- call solirr(wl,
4044 C--- s swl)
4045  swl = 1.0
4046 C---
4047  coef=sbor*step*swl
4048  seb=seb+coef
4049  wlwave=wlwave+wl*coef
4050  50 continue
4051  wlmoy=wlwave/seb
4052  return
4053  end
4054  subroutine gauss(x1,x2,x,w,n)
4055  integer n
4056  real x1,x2,x(n),w(n)
4057  double precision xm,xl,z,p1,p2,p3,pp,z1
4058  integer m,i,j
4059  parameter(eps=3.d-14)
4060  m=(n+1)/2
4061  xm=0.5d0*(x2+x1)
4062  xl=0.5d0*(x2-x1)
4063  do 12 i=1,m
4064  z=cos(3.141592654d0*(i-.25d0)/(n+.5d0))
4065 1 continue
4066  p1=1.d0
4067  p2=0.d0
4068  do 11 j=1,n
4069  p3=p2
4070  p2=p1
4071  p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
4072 11 continue
4073  pp=n*(z*p1-p2)/(z*z-1.d0)
4074  z1=z
4075  z=z1-p1/pp
4076  if(abs(z-z1).gt.eps)go to 1
4077  if (abs(z).lt.eps) z=0.
4078  x(i)=xm-xl*z
4079  x(n+1-i)=xm+xl*z
4080  w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
4081  w(n+1-i)=w(i)
4082 12 continue
4083  return
4084  end
4085  subroutine interp (iaer,idatmp,wl,taer55,taer55p,xmud,
4086  a romix,rorayl,roaero,phaa,phar,tsca,
4087  a tray,trayp,taer,taerp,dtott,utott,
4088  a astot,asray,asaer,
4089  a utotr,utota,dtotr,dtota)
4090 
4091  common /sixs_aer/ext(10),ome(10),gasym(10),phase(10)
4092  common /sixs_disc/ roatm(3,10),dtdir(3,10),dtdif(3,10),
4093  a utdir(3,10),utdif(3,10),sphal(3,10),wldis(10),trayl(10),
4094  a traypl(10)
4095  common /sixs_del/ delta,sigma
4096  Real wl,taer55,taer55p
4097  Real xmud,romix,rorayl,roaero,phaa,phar,tsca,tray
4098  Real trayp,taer,taerp,dtott,utott,astot,asray,asaer,utotr
4099  Real utota,dtotr,dtota,ext,ome,gasym,phase,roatm,dtdir
4100  Real dtdif,utdir,utdif,sphal,wldis,trayl,traypl,delta,sigma
4101  Real alphaa,betaa,alphar,betar,alphac,betac,coef,wlinf,d2
4102  Real drinf,drsup,dtinf,dtsup,dtotc,dainf,dasup,urinf,ursup
4103  Real utinf,utsup,utotc,uainf,uasup,arinf,arsup,atinf,atsup
4104  Real aainf,aasup
4105  Integer iaer,idatmp,linf,ll,lsup
4106 
4107 
4108 c that for the atmosphere :
4109 c the reflectances
4110 c rayleigh = rorayl
4111 c aerosols = roaero
4112 c mixing = romix
4113 c the downward transmittances
4114 c rayleigh = dtotr
4115 c aerosols = dtota
4116 c total = dtott
4117 c the upward transmittances
4118 c rayleigh = utotr
4119 c aerosols = utota
4120 c total = utott
4121 c the spherical albedos
4122 c rayleigh = asray
4123 c aerosols = asaer
4124 c total = astot
4125 c the optical thickness of total atmosphere
4126 c rayleigh = tray
4127 c aerosols = taer
4128 c the optical thickness of the atmosphere above the plane
4129 c rayleigh = trayp
4130 c aerosols = taerp
4131 c the tsca of the aerosols (god dammed it)
4132 c total atmosphere = tsca
4133 
4134  linf=1
4135  do 81 ll=1,9
4136  if(wl.gt.wldis(ll).and.wl.le.wldis(ll+1)) linf=ll
4137  81 continue
4138  if(wl.gt.wldis(10)) linf=9
4139  lsup=linf+1
4140 
4141 c interpolation in function of wavelength for scattering
4142 c atmospheric functions from discrete values at wldis
4143 
4144  alphaa=0.
4145  betaa=0.
4146  alphar=0.
4147  betar=0.
4148  alphac=0.
4149  betac=0.
4150  phaa=0.
4151  roaero=0.
4152  dtota=1.
4153  utota=1.
4154  asaer=0.
4155  taer=0.
4156  taerp=0.
4157  coef=alog(wldis(lsup)/wldis(linf))
4158  wlinf=wldis(linf)
4159 c
4160  if(iaer.eq.0) goto 1240
4161  alphaa=alog(phase(lsup)/phase(linf))/coef
4162  betaa=phase(linf)/(wlinf**(alphaa))
4163  phaa=betaa*(wl**alphaa)
4164  1240 d2=2.+delta
4165  phar=(2.*(1.-delta)/d2)*.75*(1.+xmud*xmud)+3.*delta/d2
4166  if (idatmp.eq.0) then
4167  betar=0.
4168  betaa=0.
4169  betac=0.
4170  goto 1234
4171  endif
4172  if(roatm(1,linf).lt..001) then
4173  rorayl=roatm(1,linf)+(roatm(1,lsup)-roatm(1,linf))
4174  s *(wl-wldis(linf))/(wldis(lsup)-wldis(linf))
4175  else
4176  alphar=alog(roatm(1,lsup)/roatm(1,linf))/ coef
4177  betar=roatm(1,linf)/(wlinf**(alphar))
4178  rorayl=betar*(wl**alphar)
4179  endif
4180  if(roatm(2,linf).lt..001) then
4181  romix=roatm(2,linf)+(roatm(2,lsup)-roatm(2,linf))
4182  s *(wl-wldis(linf))/(wldis(lsup)-wldis(linf))
4183  else
4184  alphac=alog(roatm(2,lsup)/roatm(2,linf))/coef
4185  betac=roatm(2,linf)/(wlinf**(alphac))
4186  romix=betac*(wl**alphac)
4187  endif
4188  if(iaer.eq.0) goto 1234
4189  if(roatm(3,linf).lt..001) then
4190  roaero=roatm(3,linf)+(roatm(3,lsup)-roatm(3,linf))
4191  s *(wl-wldis(linf))/(wldis(lsup)-wldis(linf))
4192  else
4193  alphaa=alog(roatm(3,lsup)/roatm(3,linf))/coef
4194  betaa=roatm(3,linf)/(wlinf**(alphaa))
4195  roaero=betaa*(wl**alphaa)
4196  endif
4197  1234 continue
4198 c
4199  alphar=alog(trayl(lsup)/trayl(linf))/coef
4200  betar=trayl(linf)/(wlinf**(alphar))
4201  tray=betar*(wl**alphar)
4202  if (idatmp.ne.0.) then
4203  alphar=alog(traypl(lsup)/traypl(linf))/coef
4204  betar=traypl(linf)/(wlinf**(alphar))
4205  trayp=betar*(wl**alphar)
4206  else
4207  trayp=0.
4208  endif
4209 c
4210  if(iaer.eq.0) goto 1235
4211  alphaa=alog(ext(lsup)*ome(lsup)/(ext(linf)*ome(linf)))/coef
4212  betaa=ext(linf)*ome(linf)/(wlinf**(alphaa))
4213  tsca=taer55*betaa*(wl**alphaa)/ext(4)
4214  alphaa=alog(ext(lsup)/ext(linf))/coef
4215  betaa=ext(linf)/(wlinf**(alphaa))
4216  taerp=taer55p*betaa*(wl**alphaa)/ext(4)
4217  taer=taer55*betaa*(wl**alphaa)/ext(4)
4218 c
4219  1235 drinf=dtdif(1,linf)+dtdir(1,linf)
4220  drsup=dtdif(1,lsup)+dtdir(1,lsup)
4221  alphar=alog(drsup/drinf)/coef
4222  betar=drinf/(wlinf**(alphar))
4223  dtotr=betar*(wl**alphar)
4224  dtinf=dtdif(2,linf)+dtdir(2,linf)
4225  dtsup=dtdif(2,lsup)+dtdir(2,lsup)
4226  alphac=alog((dtsup*drinf)/(dtinf*drsup))/coef
4227  betac=(dtinf/drinf)/(wlinf**(alphac))
4228  dtotc=betac*(wl**alphac)
4229  dainf=dtdif(3,linf)+dtdir(3,linf)
4230  dasup=dtdif(3,lsup)+dtdir(3,lsup)
4231  if(iaer.eq.0) goto 1236
4232  alphaa=alog(dasup/dainf)/coef
4233  betaa=dainf/(wlinf**(alphaa))
4234  dtota=betaa*(wl**alphaa)
4235  1236 dtott=dtotc*dtotr
4236  urinf=utdif(1,linf)+utdir(1,linf)
4237  ursup=utdif(1,lsup)+utdir(1,lsup)
4238  alphar=alog(ursup/urinf)/ coef
4239  betar=urinf/(wlinf**(alphar))
4240  utotr=betar*(wl**alphar)
4241  utinf=utdif(2,linf)+utdir(2,linf)
4242  utsup=utdif(2,lsup)+utdir(2,lsup)
4243  alphac=alog((utsup*urinf)/(utinf*ursup))/ coef
4244  betac=(utinf/urinf)/(wlinf**(alphac))
4245  utotc=betac*(wl**alphac)
4246  uainf=utdif(3,linf)+utdir(3,linf)
4247  uasup=utdif(3,lsup)+utdir(3,lsup)
4248  if(iaer.eq.0) goto 1237
4249  alphaa=alog(uasup/uainf)/ coef
4250  betaa=uainf/(wlinf**(alphaa))
4251  utota=betaa*(wl**alphaa)
4252  1237 utott=utotc*utotr
4253  arinf=sphal(1,linf)
4254  arsup=sphal(1,lsup)
4255  alphar=alog(arsup/arinf)/ coef
4256  betar=arinf/(wlinf**(alphar))
4257  asray=betar*(wl**alphar)
4258  atinf=sphal(2,linf)
4259  atsup=sphal(2,lsup)
4260  alphac=alog(atsup/atinf)/coef
4261  betac=atinf/(wlinf**(alphac))
4262  astot=betac*(wl**alphac)
4263  aainf=sphal(3,linf)
4264  aasup=sphal(3,lsup)
4265  if(iaer.eq.0) goto 1239
4266  alphaa=alog(aasup/aainf)/coef
4267  betaa=aainf/(wlinf**(alphaa))
4268  asaer=betaa*(wl**alphaa)
4269  1239 return
4270  end
4271  subroutine iso(tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt,
4272  s nt,mu,rm,gb,
4273  s xf)
4274 c dimension for gauss integration
4275  integer mu
4276  real rm(-mu:mu),gb(-mu:mu)
4277 c dimension for os computation
4278  real xf(-1:1)
4279 c array for sos computation
4280  real xpl(-25:25),psl(-1:80,-25:25),bp(0:25,-25:25),
4281  s xdel(0:30),ydel(0:30),h(0:30)
4282  real i1(0:30,-25:25),i2(0:30,-25:25),i3(-25:25),
4283  s in(-25:25),inm1(-25:25),inm2(-25:25)
4284  real altc(0:30)
4285  real ii1,ii2
4286  Real tamoy,trmoy,pizmoy
4287  Real tamoyp,trmoyp,palt
4288  Real delta,sigma,pha,betal,accu,accu2,ta,piz
4289  Real tr,trp,tap,hr,ha,zx,yy,dd,ppp2,ppp1,ca
4290  Real cr,ratio,taup,th,xt1,xt2,aaaa,ron,beta0,beta2
4291  Real tavion0,tavion1,tavion2,tavion,zi1,xpk,ypk,x,y,xpj
4292  Real z,xi1,xi2,bpjk,bpjmk,f,a,b,c,d,xx,a1,d1,g1
4293  Real y1
4294  Double precision xxx
4295  integer snt,nt,iplane,ntp,j,it,itp,i,ig,k,index,iwr,m
4296  integer jj,l
4297  logical ier
4298  common/sixs_del/delta,sigma
4299  common/sixs_trunc/pha(83),betal(0:80)
4300  common/sixs_ier/iwr,ier
4301  snt=nt
4302  iplane=0
4303  accu=1.e-20
4304  accu2=1.e-3
4305  ta=tamoy
4306  piz=pizmoy
4307  tr=trmoy
4308  do 615 m=-1,1
4309  615 xf(m)=0.
4310 c
4311 c molecular ratio within the layer
4312 c computations are performed assuming a scale of 8km for
4313 c molecules and 2km for aerosols
4314 c
4315 c the optical thickness above plane are recomputed to give o.t above pla
4316  trp=trmoy-trmoyp
4317  tap=tamoy-tamoyp
4318 c print *, 'tamoy,trmoy,pizmoy,tap,trp,palt,nt'
4319 c print *,tamoy,trmoy,pizmoy,tap,trp,palt,nt
4320  accu=1.e-20
4321 c if plane observations recompute scale height for aerosol knowing:
4322 c the aerosol optical depth as measure from the plane = tamoyp
4323 c the rayleigh scale height = = hr (8km)
4324 c the rayleigh optical depth at plane level = trmoyp
4325 c the altitude of the plane = palt
4326 c the rayleigh optical depth for total atmos = trmoy
4327 c the aerosol optical depth for total atmos = tamoy
4328 c if not plane observations then ha is equal to 2.0km
4329 c ntp local variable: if ntp=nt no plane observation selected
4330 c ntp=nt-1 plane observation selected
4331  hr=8.0
4332 c it's a mixing rayleigh+aerosol
4333  if(palt.le.900..and.palt.gt.0.0)then
4334  if (tap.gt.1.e-03) then
4335  ha=-palt/log(tap/ta)
4336  else
4337  ha=2.
4338  endif
4339  ntp=nt-1
4340  else
4341  ha=2.0
4342  ntp=nt
4343  endif
4344 c
4345  ta=tamoy
4346  tr=trmoy
4347  piz=pizmoy
4348 c
4349 c compute mixing rayleigh, aerosol
4350 c case 1: pure rayleigh
4351 c case 2: pure aerosol
4352 c case 3: mixing rayleigh-aerosol
4353 c
4354  if((ta.le.accu2).and.(tr.gt.ta)) then
4355  do j=0,ntp
4356  h(j)=j*tr/ntp
4357  ydel(j)=1.0
4358  xdel(j)=0.0
4359  enddo
4360  endif
4361  if((tr.le.accu2).and.(ta.gt.tr)) then
4362  do j=0,ntp
4363  h(j)=j*ta/ntp
4364  ydel(j)=0.0
4365  xdel(j)=piz
4366  enddo
4367  endif
4368 c
4369  if(tr.gt.accu2.and.ta.gt.accu2)then
4370  ydel(0)=1.0
4371  xdel(0)=0.0
4372  h(0)=0.
4373  altc(0)=300.
4374  zx=300.
4375  iplane=0
4376  do 14 it=0,ntp
4377  if (it.eq.0) then
4378  yy=0.
4379  dd=0.
4380  goto 111
4381  endif
4382  yy=h(it-1)
4383  dd=ydel(it-1)
4384  111 ppp2=300.0
4385  ppp1=0.0
4386  itp=it
4387  call discre(ta,ha,tr,hr,itp,ntp,yy,dd,ppp2,ppp1,
4388  s zx)
4389  if(ier)return
4390  xxx=-zx/ha
4391  if (xxx.lt.-18) then
4392  ca=0.
4393  else
4394  ca=ta*dexp(xxx)
4395  endif
4396  xxx=-zx/hr
4397  cr=tr*dexp(xxx)
4398  h(it)=cr+ca
4399  altc(it)=zx
4400 c print *,it,cr,ca,h(it),zx
4401  cr=cr/hr
4402  ca=ca/ha
4403  ratio=cr/(cr+ca)
4404  xdel(it)=(1.e+00-ratio)*piz
4405  ydel(it)=ratio
4406  14 continue
4407  endif
4408 c update plane layer if necessary
4409  if (ntp.eq.(nt-1)) then
4410 c compute position of the plane layer
4411  taup=tap+trp
4412  iplane=-1
4413  do i=0,ntp
4414  if (taup.ge.h(i)) iplane=i
4415  enddo
4416 c update the layer from the end to the position to update if necessary
4417  th=0.0005
4418  xt1=abs(h(iplane)-taup)
4419  xt2=abs(h(iplane+1)-taup)
4420  if ((xt1.gt.th).and.(xt2.gt.th)) then
4421  do i=nt,iplane+1,-1
4422  xdel(i)=xdel(i-1)
4423  ydel(i)=ydel(i-1)
4424  h(i)=h(i-1)
4425  altc(i)=altc(i-1)
4426  enddo
4427  else
4428  nt=ntp
4429  if (xt2.lt.xt1) iplane=iplane+1
4430  endif
4431  h(iplane)=taup
4432  if ( tr.gt.accu2.and.ta.gt.accu2) then
4433  ca=ta*exp(-palt/ha)
4434  cr=tr*exp(-palt/hr)
4435  cr=cr/hr
4436  ca=ca/ha
4437  ratio=cr/(cr+ca)
4438  xdel(iplane)=(1.e+00-ratio)*piz
4439  ydel(iplane)=ratio
4440  altc(iplane)=palt
4441  endif
4442  if ( tr.gt.accu2.and.ta.le.accu2) then
4443  ydel(iplane)=1.
4444  xdel(iplane)=0.
4445  altc(iplane)=palt
4446  endif
4447  if ( tr.le.accu2.and.ta.gt.accu2) then
4448  ydel(iplane)=0.
4449  xdel(iplane)=1.*piz
4450  altc(iplane)=palt
4451  endif
4452  endif
4453 c
4454 c print *,ha,hr,palt,tamoy,trmoy,tap,trp
4455 c do i=0,nt
4456 c print *,i,h(i),xdel(i),ydel(i),altc(i)
4457 c enddo
4458 c
4459  aaaa=delta/(2-delta)
4460  ron=(1-aaaa)/(1+2*aaaa)
4461 c
4462 c rayleigh phase function
4463 c
4464  beta0=1.
4465  beta2=0.5*ron
4466 c
4467 c primary scattering
4468 c
4469  ig=1
4470  tavion0=0.
4471  tavion1=0.
4472  tavion2=0.
4473  tavion=0.
4474  do 16 j=-mu,mu
4475  i3(j)=0.
4476  16 continue
4477 c
4478 c kernel computations
4479 c
4480  call kernel(0,mu,rm,xpl,psl,bp)
4481  do 100 j=-mu,mu
4482  do 101 k=0,nt
4483  i2(k,j)=0.0000
4484  101 continue
4485  100 continue
4486 c
4487 c vertical integration, primary upward radiation
4488 c
4489 
4490  do 108 k=1,mu
4491  i1(nt,k)=1.0
4492  zi1=i1(nt,k)
4493  yy=rm(k)
4494  do 108 i=nt-1,0,-1
4495  i1(i,k)=exp(-(ta+tr-h(i))/yy)
4496  108 continue
4497 c
4498 c vertical integration, primary downward radiation
4499 c
4500  do 109 k=-mu,-1
4501  do 109 i=0,nt
4502  i1(i,k)=0.00
4503  109 continue
4504 c
4505 c inm2 is inialized with scattering computed at n-2
4506 c i3 is inialized with primary scattering
4507 c
4508  do 20 k=-mu,mu
4509  if(k) 21,20,23
4510  21 index=nt
4511  go to 25
4512  23 index=0
4513  25 continue
4514  inm1(k)=i1(index,k)
4515  inm2(k)=i1(index,k)
4516  i3(k)=i1(index,k)
4517  20 continue
4518  tavion=i1(iplane,mu)
4519  tavion2=i1(iplane,mu)
4520 c
4521 c loop on successive order
4522 c
4523  503 ig=ig+1
4524 c write(6,*) 'ig ',ig
4525 c
4526 c successive orders
4527 c
4528 c multiple scattering source function at every level within the laye
4529 c
4530 c
4531  do455 k=1,mu
4532  xpk=xpl(k)
4533  ypk=xpl(-k)
4534  do 455 i=0,nt
4535  ii1=0.
4536  ii2=0.
4537  x=xdel(i)
4538  y=ydel(i)
4539  do477 j=1,mu
4540  xpj=xpl(j)
4541  z=gb(j)
4542  xi1=i1(i,j)
4543  xi2=i1(i,-j)
4544  bpjk=bp(j,k)*x+y*(beta0+beta2*xpj*xpk)
4545  bpjmk=bp(j,-k)*x+y*(beta0+beta2*xpj*ypk)
4546  ii2=ii2+z*(xi1*bpjk+xi2*bpjmk)
4547  ii1=ii1+z*(xi1*bpjmk+xi2*bpjk)
4548  477 continue
4549  i2(i,k)=ii2
4550  i2(i,-k)=ii1
4551  455 continue
4552 c
4553 c vertical integration, upward radiation
4554 c
4555  do 48 k=1,mu
4556  i1(nt,k)=0.0
4557  zi1=i1(nt,k)
4558  yy=rm(k)
4559  do 48 i=nt-1,0,-1
4560  jj=i+1
4561  f=h(jj)-h(i)
4562  a=(i2(jj,k)-i2(i,k))/f
4563  b=i2(i,k)-a*h(i)
4564  c=exp(-f/yy)
4565  d=1.e+00-c
4566  xx=h(i)-h(jj)*c
4567  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
4568  i1(i,k)=zi1
4569  48 continue
4570 c
4571 c vertical integration, downward radiation
4572 c
4573  do 50 k=-mu,-1
4574  i1(0,k)=0.
4575  zi1=i1(0,k)
4576  yy=rm(k)
4577  do 50 i=1,nt
4578  jj=i-1
4579  f=h(i)-h(jj)
4580  c=exp(f/yy)
4581  d=1.e+00-c
4582  a=(i2(i,k)-i2(jj,k))/f
4583  b=i2(i,k)-a*h(i)
4584  xx=h(i)-h(jj)*c
4585  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
4586  i1(i,k)=zi1
4587  50 continue
4588 c
4589 c in is the nieme scattering order
4590 c
4591  do 30 k=-mu,mu
4592  if(k) 31,30,33
4593  31 index=nt
4594  go to 34
4595  33 index=0
4596  34 continue
4597  in(k)=i1(index,k)
4598  30 continue
4599  tavion0=i1(iplane,mu)
4600 c
4601 c convergence test (geometrical serie)
4602 c
4603  if(ig.gt.2) then
4604  z=0.
4605  a1=tavion2
4606  d1=tavion1
4607  g1=tavion0
4608  if (a1.ge.accu.and.d1.ge.accu.and.tavion.ge.accu) then
4609  y=((g1/d1-d1/a1)/((1.-g1/d1)**2)*(g1/tavion))
4610  y=abs(y)
4611  z=amax1(y,z)
4612  endif
4613  do 99 l=-mu,mu
4614  if (l.eq.0) goto 99
4615  a1=inm2(l)
4616  d1=inm1(l)
4617  g1=in(l)
4618  if(a1.eq.0.) go to 99
4619  if(d1.eq.0.) go to 99
4620  if(i3(l).eq.0.) go to 99
4621  y=((g1/d1-d1/a1)/((1-g1/d1)**2)*(g1/i3(l)))
4622  y=abs(y)
4623  z=amax1(y,z)
4624  99 continue
4625  if(z.lt.0.0001) then
4626 c
4627 c successful test (geometrical serie)
4628 c
4629  do 606 l=-mu,mu
4630  if (l.eq.0) goto 606
4631  y1=1.
4632  d1=inm1(l)
4633  g1=in(l)
4634  if(d1.eq.0.0) go to 606
4635  y1=1-g1/d1
4636  g1=g1/y1
4637  i3(l)=i3(l)+g1
4638  606 continue
4639  d1=tavion1
4640  g1=tavion0
4641  y1=1.
4642  if (d1.ge.accu) then
4643  if (abs(g1-d1).ge.accu) then
4644  y1=1.-g1/d1
4645  g1=g1/y1
4646  endif
4647  tavion=tavion+g1
4648  endif
4649  go to 505
4650  endif
4651 c
4652 c inm2 is the (n-2)ieme scattering order
4653 c
4654  do 26 k=-mu,mu
4655  inm2(k)=inm1(k)
4656  26 continue
4657  tavion2=tavion1
4658  endif
4659 c
4660 c inm1 is the (n-1)ieme scattering order
4661 c
4662  do 27 k=-mu,mu
4663  inm1(k)=in(k)
4664  27 continue
4665  tavion1=tavion0
4666 c
4667 c sum of the n-1 orders
4668 c
4669  do 610 l=-mu,mu
4670  i3(l)=i3(l)+in(l)
4671  610 continue
4672  tavion=tavion+tavion0
4673 c
4674 c stop if order n is less than 1% of the sum
4675 c
4676  z=0.
4677  do 611 l=-mu,mu
4678  if(i3(l).ne.0)then
4679  y=abs(in(l)/i3(l))
4680  z=amax1(z,y)
4681  endif
4682  611 continue
4683  if(z.lt.0.00001) go to 505
4684 c
4685 c stop if order n is greater than 20 in any case
4686 c
4687  if(ig-20) 503,503,505
4688  505 continue
4689 c
4690 c
4691  xf(1)=xf(1)+i3(mu)
4692  xf(-1)=tavion
4693  do k=1,mu
4694  xf(0)=xf(0)+rm(k)*gb(k)*i3(-k)
4695  enddo
4696  nt=snt
4697  return
4698  end
4699  subroutine kernel(is,mu,rm,xpl,psl,bp)
4700  integer mu
4701  real rm(-mu:mu)
4702  real psl(-1:80,-25:25),xpl(-25:25),bp(0:25,-25:25)
4703  real pha,betal
4704  integer is,ip1,j,i,k,ip,ig,l,lp,lm,ij
4705  double precision xdb,a,b,c,xx,rac3,x,bt,sbp
4706  common /sixs_trunc/pha(83),betal(0:80)
4707  ip1=80
4708  rac3=dsqrt(3.d+00)
4709  if(is.ne.0)go to 700
4710  do 25 j=0,mu
4711  c=dble(rm(j))
4712  psl(0,-j)=1.
4713  psl(0,j)=1.
4714  psl(1,j)=c
4715  psl(1,-j)=-c
4716  xdb=(3.*c*c-1.)*0.5
4717  if (abs(xdb).lt.1.e-30) xdb=0.0
4718  psl(2,-j)=xdb
4719  psl(2,j)=xdb
4720  25 continue
4721  psl(1,0)=rm(0)
4722  goto 501
4723 c
4724  700 if(is.ne.1)go to 701
4725  do 26 j=0,mu
4726  c=dble(rm(j))
4727  x=1.-c*c
4728  psl(0,j)=0.
4729  psl(0,-j)=0.
4730  psl(1,-j)=sqrt(x*0.5)
4731  psl(1,j)=sqrt(x*0.5)
4732  psl(2,j)=c*psl(1,j)*rac3
4733  psl(2,-j)=-psl(2,j)
4734  26 continue
4735  psl(2,0)=-psl(2,0)
4736  goto 501
4737 c
4738  701 a=1
4739  do 27 i=1,is
4740  x=i
4741  a=a*sqrt((i+is)/x)*0.5
4742  27 continue
4743  b=a*sqrt(is/(is+1.))*sqrt((is-1.)/(is+2.))
4744  do 28 j=0,mu
4745  c=dble(rm(j))
4746  xx=1.-c*c
4747  psl(is-1,j)=0.
4748  xdb=a*xx**(is*0.5)
4749  if (abs(xdb).lt.1.e-30) xdb=0.0
4750  psl(is,-j)=xdb
4751  psl(is,j)=xdb
4752  28 continue
4753  501 k=2
4754  ip=ip1
4755  if(is.gt.2)k=is
4756  if(k.eq.ip)goto 502
4757  ig=-1
4758  if(is.eq.1)ig=1
4759  do 30 l=k,ip-1
4760  lp=l+1
4761  lm=l-1
4762  a=(2*l+1.)/sqrt((l+is+1.)*(l-is+1.))
4763  b=sqrt(float((l+is)*(l-is)))/(2.*l+1.)
4764  do 31 j=0,mu
4765  c=dble(rm(j))
4766  xdb=a*(c*psl(l,j)-b*psl(lm,j))
4767  if (abs(xdb).lt.1.e-30) xdb=0.
4768  psl(lp,j)=xdb
4769  if(j.eq.0) go to 31
4770  psl(lp,-j)=ig*psl(lp,j)
4771  31 continue
4772  ig=-ig
4773  30 continue
4774  502 continue
4775  do 1005 j=-mu,mu
4776  xpl(j)=psl(2,j)
4777  1005 continue
4778  ij=ip1
4779  do 32 j=0,mu
4780  do 32 k=-mu,mu
4781  sbp=0.
4782  if(is.gt.ij) goto 1
4783  do 33 l=is,ij
4784  bt=betal(l)
4785  sbp=sbp+dble(psl(l,j))*psl(l,k)*bt
4786  33 continue
4787  1 continue
4788  if (abs(sbp).lt.1.e-30) sbp=0.
4789  bp(j,k)=sbp
4790  32 continue
4791  return
4792  end
4793  subroutine midsum
4794  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
4795  real z2(34),p2(34),t2(34),wh2(34),wo2(34)
4796  real z,p,t,wh,wo
4797  integer i
4798 c
4799 c model: midlatitude summer mc clatchey
4800 c
4801  data(z2(i),i=1, 34)/
4802  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
4803  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
4804  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
4805  4 35., 40., 45., 50., 70., 100.,99999./
4806  data (p2(i),i=1,34) /
4807  a1.013e+03,9.020e+02,8.020e+02,7.100e+02,6.280e+02,5.540e+02,
4808  a4.870e+02,4.260e+02,3.720e+02,3.240e+02,2.810e+02,2.430e+02,
4809  a2.090e+02,1.790e+02,1.530e+02,1.300e+02,1.110e+02,9.500e+01,
4810  a8.120e+01,6.950e+01,5.950e+01,5.100e+01,4.370e+01,3.760e+01,
4811  a3.220e+01,2.770e+01,1.320e+01,6.520e+00,3.330e+00,1.760e+00,
4812  a9.510e-01,6.710e-02,3.000e-04,0.000e+00/
4813  data (t2(i),i=1,34) /
4814  a2.940e+02,2.900e+02,2.850e+02,2.790e+02,2.730e+02,2.670e+02,
4815  a2.610e+02,2.550e+02,2.480e+02,2.420e+02,2.350e+02,2.290e+02,
4816  a2.220e+02,2.160e+02,2.160e+02,2.160e+02,2.160e+02,2.160e+02,
4817  a2.160e+02,2.170e+02,2.180e+02,2.190e+02,2.200e+02,2.220e+02,
4818  a2.230e+02,2.240e+02,2.340e+02,2.450e+02,2.580e+02,2.700e+02,
4819  a2.760e+02,2.180e+02,2.100e+02,2.100e+02/
4820  data (wh2(i),i=1,34) /
4821  a1.400e+01,9.300e+00,5.900e+00,3.300e+00,1.900e+00,1.000e+00,
4822  a6.100e-01,3.700e-01,2.100e-01,1.200e-01,6.400e-02,2.200e-02,
4823  a6.000e-03,1.800e-03,1.000e-03,7.600e-04,6.400e-04,5.600e-04,
4824  a5.000e-04,4.900e-04,4.500e-04,5.100e-04,5.100e-04,5.400e-04,
4825  a6.000e-04,6.700e-04,3.600e-04,1.100e-04,4.300e-05,1.900e-05,
4826  a1.300e-06,1.400e-07,1.000e-09,0.000e+00/
4827  data (wo2(i),i=1,34) /
4828  a6.000e-05,6.000e-05,6.000e-05,6.200e-05,6.400e-05,6.600e-05,
4829  a6.900e-05,7.500e-05,7.900e-05,8.600e-05,9.000e-05,1.100e-04,
4830  a1.200e-04,1.500e-04,1.800e-04,1.900e-04,2.100e-04,2.400e-04,
4831  a2.800e-04,3.200e-04,3.400e-04,3.600e-04,3.600e-04,3.400e-04,
4832  a3.200e-04,3.000e-04,2.000e-04,9.200e-05,4.100e-05,1.300e-05,
4833  a4.300e-06,8.600e-08,4.300e-11,0.000e+00/
4834  do 1 i=1,34
4835  z(i)=z2(i)
4836  p(i)=p2(i)
4837  t(i)=t2(i)
4838  wh(i)=wh2(i)
4839  wo(i)=wo2(i)
4840  1 continue
4841  return
4842  end
4843  subroutine midwin
4844  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
4845  real z3(34),p3(34),t3(34),wh3(34),wo3(34)
4846  real z,p,t,wh,wo
4847  integer i
4848 c
4849 c model: midlatitude winter mc clatchey
4850 c
4851  data(z3(i),i=1, 34)/
4852  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
4853  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
4854  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
4855  4 35., 40., 45., 50., 70., 100.,99999./
4856  data (p3(i),i=1,34) /
4857  a1.018e+03,8.973e+02,7.897e+02,6.938e+02,6.081e+02,5.313e+02,
4858  a4.627e+02,4.016e+02,3.473e+02,2.992e+02,2.568e+02,2.199e+02,
4859  a1.882e+02,1.610e+02,1.378e+02,1.178e+02,1.007e+02,8.610e+01,
4860  a7.350e+01,6.280e+01,5.370e+01,4.580e+01,3.910e+01,3.340e+01,
4861  a2.860e+01,2.430e+01,1.110e+01,5.180e+00,2.530e+00,1.290e+00,
4862  a6.820e-01,4.670e-02,3.000e-04,0.000e+00/
4863  data (t3(i),i=1,34) /
4864  a2.722e+02,2.687e+02,2.652e+02,2.617e+02,2.557e+02,2.497e+02,
4865  a2.437e+02,2.377e+02,2.317e+02,2.257e+02,2.197e+02,2.192e+02,
4866  a2.187e+02,2.182e+02,2.177e+02,2.172e+02,2.167e+02,2.162e+02,
4867  a2.157e+02,2.152e+02,2.152e+02,2.152e+02,2.152e+02,2.152e+02,
4868  a2.152e+02,2.152e+02,2.174e+02,2.278e+02,2.432e+02,2.585e+02,
4869  a2.657e+02,2.307e+02,2.102e+02,2.100e+02/
4870  data (wh3(i),i=1,34) /
4871  a3.500e+00,2.500e+00,1.800e+00,1.200e+00,6.600e-01,3.800e-01,
4872  a2.100e-01,8.500e-02,3.500e-02,1.600e-02,7.500e-03,6.900e-03,
4873  a6.000e-03,1.800e-03,1.000e-03,7.600e-04,6.400e-04,5.600e-04,
4874  a5.000e-04,4.900e-04,4.500e-04,5.100e-04,5.100e-04,5.400e-04,
4875  a6.000e-04,6.700e-04,3.600e-04,1.100e-04,4.300e-05,1.900e-05,
4876  a6.300e-06,1.400e-07,1.000e-09,0.000e+00/
4877  data (wo3(i),i=1,34) /
4878  a6.000e-05,5.400e-05,4.900e-05,4.900e-05,4.900e-05,5.800e-05,
4879  a6.400e-05,7.700e-05,9.000e-05,1.200e-04,1.600e-04,2.100e-04,
4880  a2.600e-04,3.000e-04,3.200e-04,3.400e-04,3.600e-04,3.900e-04,
4881  a4.100e-04,4.300e-04,4.500e-04,4.300e-04,4.300e-04,3.900e-04,
4882  a3.600e-04,3.400e-04,1.900e-04,9.200e-05,4.100e-05,1.300e-05,
4883  a4.300e-06,8.600e-08,4.300e-11,0.000e+00/
4884  do 1 i=1,34
4885  z(i)=z3(i)
4886  p(i)=p3(i)
4887  t(i)=t3(i)
4888  wh(i)=wh3(i)
4889  wo(i)=wo3(i)
4890  1 continue
4891  return
4892  end
4893  subroutine mie(iaer,wldis,ex,sc,asy)
4894 
4895  double precision nr,p11(83),p1(10,4,83),ext(10,4),sca(10,4),np(4)
4896  double precision pi,r,rmind,rmaxd,r0,alpha,dr,xndpr2,Qext,Qsca
4897  double precision rlogpas
4898  real ex(4,10),sc(4,10),asy(4,10),wldis(10)
4899  real phasel,cgaus,pdgs,rmax,rmin,rn,ri,x1,x2,x3,rsunph,nrsunph
4900  real asy_n,asy_d,cij,ph
4901  integer nbmu,icp,i,j,l,k,iaer,irsunph
4902  double precision arg,ldexp
4903 
4904  common /sixs_sos/ phasel(10,83),cgaus(83),pdgs(83)
4905  common /mie_in/ rmax,rmin,icp,rn(10,4),ri(10,4),x1(4),x2(4),
4906  s x3(4),cij(4),irsunph,rsunph(50),nrsunph(50)
4907  common /sixs_aerbas/ ph(10,83)
4908 
4909  ldexp=-300.
4910  pi=4.d+00*datan(1.d+00)
4911  rlogpas=0.030
4912  nbmu=83
4913  do i=1,icp
4914  np(i)=0.d+00
4915  do l=1,10
4916  ex(i,l)=0.0
4917  sc(i,l)=0.0
4918  asy(i,l)=0.0
4919  ext(l,i)=0.d+00
4920  sca(l,i)=0.d+00
4921  do k=1,nbmu
4922  p1(l,i,k)=0.d+00
4923  enddo
4924  enddo
4925  enddo
4926  rmaxd=dble(rmax)
4927  rmind=dble(rmin)
4928 
4929 c LOOPS ON THE NUMBER OF PARTICLE TYPE (4 max)
4930  do 600 i=1,icp
4931  r=rmind
4932  dr=r*(10**rlogpas-1.d+00)
4933  123 continue
4934 C LOOPS ON THE RADIUS OF THE PARTICLE
4935 
4936 c call of the size distribution nr. For our computation, we need dn/dr for
4937 c all functions except for sun-photometer inputs for which we need dV/dlog(r)
4938  goto(300,301,302,303)iaer-7
4939 C --- Mixture of particles (Log-Normal distribution functions, up to 5)
4940  300 nr=dexp(-5.d-01*(dlog10(r/x1(i))/dlog10(1.d+00*x2(i)))**2.d+00)
4941  nr=nr/dsqrt(2.d+00*pi)/dlog10(1.d+00*x2(i))
4942  nr=nr/dlog(10.d+00)/r
4943  goto 399
4944 
4945 c --- Modified Gamma distribution function
4946  301 r0=1.00d+00
4947  arg=-x2(i)*((r/r0)**x3(i))
4948  if (arg.gt.ldexp) then
4949  nr=((r/r0)**x1(i))*dexp(arg)
4950  else
4951  nr=0.
4952  endif
4953  goto 399
4954 
4955 C --- Junge power-law function
4956  302 r0=0.1000d+00
4957  nr= r0**(-x1(i))
4958  IF(r.GT.r0 ) nr= r**(-x1(i))
4959  goto 399
4960 C
4961 C --- from sun photometer
4962  303 nr=0.d+00
4963  do 299 j=2,irsunph
4964  if ((r-rsunph(j)).lt.0.000001)then
4965  nr=(r-rsunph(j-1))/(rsunph(j)-rsunph(j-1))
4966  nr=nrsunph(j-1)+nr*(nrsunph(j)-nrsunph(j-1))
4967  goto 399
4968  endif
4969  299 continue
4970 C
4971 c The Mie's calculations have to be called several times (min=2, max=10 for
4972 c each type of particle): at wavelengths bounding the range of the selected
4973 c wavelengths,and at 0.550 microns to normalized the extinction coefficient
4974 c (if it's not in the selected range of wavelengths).
4975  399 continue
4976  xndpr2=nr*dr*pi*(r**2.d+00)
4977 c relatif number of particle for each type of particle (has to be equal to 1)
4978  np(i)=np(i)+nr*dr
4979  do l=1,10
4980 
4981  if ((xndpr2*cij(i)).lt.(1.d-08/sqrt(wldis(l))))goto 599
4982 
4983  alpha=2.d+00*pi*r/wldis(l)
4984  call exscphase(alpha,rn(l,i),ri(l,i),qext,qsca,p11)
4985  ext(l,i)=ext(l,i)+xndpr2*qext
4986  sca(l,i)=sca(l,i)+xndpr2*qsca
4987 c phase function for each type of particle
4988  do k=1,nbmu
4989  p1(l,i,k)=p1(l,i,k)+p11(k)*xndpr2
4990  enddo
4991  enddo
4992  599 continue
4993  r=r+dr
4994  dr=r*(10**rlogpas-1.d+00)
4995  if(r.ge.rmaxd) goto 600
4996  goto 123
4997  600 continue
4998 
4999 
5000 c NOW WE MIXTE THE DIFFERENT TYPES OF PARTICLE
5001 c computation of the scattering and extinction coefficients. We first start
5002 c at 0.550 micron (the extinction coefficient is normalized at 0.550 micron)
5003  do l=1,10
5004  do i=1,icp
5005  ext(l,i)=ext(l,i)/np(i)/1.d+03
5006  sca(l,i)=sca(l,i)/np(i)/1.d+03
5007  ex(1,l)=ex(1,l)+cij(i)*real(ext(l,i))
5008  sc(1,l)=sc(1,l)+cij(i)*real(sca(l,i))
5009  enddo
5010  enddo
5011 c computation of the phase function and the asymetry coefficient
5012 c of the mixture of particles
5013  do l=1,10
5014  asy_n=0.
5015  asy_d=0.
5016  do k=1,nbmu
5017  ph(l,k)=0.
5018  do i=1,icp
5019  ph(l,k)=ph(l,k)+real(cij(i)*p1(l,i,k)/np(i)/1.d+3)
5020  enddo
5021  ph(l,k)=ph(l,k)/sc(1,l)
5022  asy_n=asy_n+cgaus(k)*ph(l,k)*pdgs(k)/10.
5023  asy_d=asy_d+ph(l,k)*pdgs(k)/10.
5024  enddo
5025  asy(1,l)=asy_n/asy_d
5026  enddo
5027 
5028  return
5029  END
5030 C***************************************************************************
5031 C Using the Mie's theory, this subroutine compute the scattering and
5032 C extinction efficiency factors (usually written Qsca and Qext) and it also
5033 C compute the scattering intensity efficiency
5034  subroutine exscphase(X,nr,ni,Qext,Qsca,p11)
5035  parameter(nser=10000)
5036  double precision Ren,Imn,X,Up,XnumRDnY,XnumIDnY
5037  double precision XdenDnY,coxj,Qsca,Qext,xJonH,XdenGNX
5038  double precision Xnum1An,Xnum2An,XdenAn,Xden1An,Xden2An,RAnb,IAnb
5039  double precision Xnum1Bn,Xnum2Bn,XdenBn,Xden1Bn,Xden2Bn,RBnb,IBnb
5040  double precision xmud,xpond,RS1,RS2,IS1,IS2,co_n,test
5041  double precision xj(0:nser),xy(-1:nser),Rn(0:nser)
5042  double precision IDnY(0:nser),RDnX(0:nser),RDnY(0:nser)
5043  double precision IGnX(0:nser),RGnX(0:nser)
5044  double precision RAn(0:nser),IAn(0:nser),RBn(0:nser),IBn(0:nser)
5045  double precision TAUn(0:nser),PIn(0:nser),p11(83)
5046  real nr,ni,cgaus,phasel,pdgs
5047  integer N,Np,mu,mub,mu1,mu2,k,nbmu,j
5048 
5049  common /sixs_sos/ phasel(10,83),cgaus(83),pdgs(83)
5050 
5051  nbmu=83
5052 
5053  ren=nr/(nr*nr+ni*ni)
5054  imn=ni/(nr*nr+ni*ni)
5055 
5056 c ---Identification of the greater order of computation (=mu)
5057 c as defined by F.J. Corbato, J. Assoc. Computing Machinery, 1959,
5058 c 6, 366-375
5059  n=int(0.5d+00*(-1.d+00+dsqrt(1.d+00+4.d+00*x*x)))+1
5060  if (n.eq.1)n=2
5061 
5062  mu2=1000000
5063  np=n
5064  up=2.d+00*x/(2.d+00*np+1.d+00)
5065  mu1=int(np+30.*(0.10+0.35*up*(2-up*up)/2./(1-up)))
5066  np=int(x-0.5d+00+dsqrt(30.*0.35*x))
5067  if (np.gt.n)then
5068  up=2.d+00*x/(2.d+00*np+1.d+00)
5069  mu2=int(np+30.*(0.10+0.35*up*(2-up*up)/2./(1-up)))
5070  endif
5071  mu=min0(mu1,mu2)
5072 
5073 c --- Identification of the transition line. Below this line the Bessel
5074 c function j behaves as oscillating functions. Above the behavior
5075 c becomes monotonic. We start at a order greater than this transition
5076 c line (order max=mu) because a downward recursion is called for.
5077  rn(mu)=0.d+00
5078  k=mu+1
5079  149 continue
5080  k=k-1
5081  xj(k)=0.d+00
5082  rn(k-1)=x/(2.d+00*k+1.d+00-x*rn(k))
5083  if (k.eq.2)then
5084  mub=mu
5085  xj(mub+1)=0.d+00
5086  xj(mub)=1.d+00
5087  goto 150
5088  endif
5089  if (rn(k-1).gt.1.d+00)then
5090  mub=k-1
5091  xj(mub+1)=rn(mub)
5092  xj(mub)=1.d+00
5093  goto 150
5094  endif
5095  goto 149
5096  150 continue
5097 
5098  do k=mub,1,-1
5099  xj(k-1)=(2.d+00*k+1.d+00)*xj(k)/x-xj(k+1)
5100  enddo
5101  coxj=(xj(0)-x*xj(1))*dcos(x)+x*xj(0)*sin(x)
5102 
5103 c --- Computation Dn(alpha) and Dn(alpha*m) (cf MIE's theory)
5104 c downward recursion - real and imaginary parts
5105  rdny(mu)=0.d+00
5106  idny(mu)=0.d+00
5107  rdnx(mu)=0.d+00
5108  do k=mu,1,-1
5109  rdnx(k-1)=k/x-1.d+00/(rdnx(k)+k/x)
5110  xnumrdny=rdny(k)+ren*k/x
5111  xnumidny=idny(k)+imn*k/x
5112  xdendny=xnumrdny*xnumrdny+xnumidny*xnumidny
5113  rdny(k-1)=k*ren/x-xnumrdny/xdendny
5114  idny(k-1)=k*imn/x+xnumidny/xdendny
5115 
5116  enddo
5117 
5118 c --- Initialization of the upward recursions
5119  xy(-1)=dsin(x)/x
5120  xy(0)=-dcos(x)/x
5121  rgnx(0)=0.d+00
5122  ignx(0)=-1.d+00
5123  qsca=0.d+00
5124  qext=0.d+00
5125  do k=1,mu
5126  if (k.le.mub)then
5127  xj(k)=xj(k)/coxj
5128  else
5129  xj(k)=rn(k-1)*xj(k-1)
5130  endif
5131 
5132 c --- Computation of bessel's function y(alpha)
5133  xy(k)=(2.d+00*k-1.d+00)*xy(k-1)/x-xy(k-2)
5134  xjonh=xj(k)/(xj(k)*xj(k)+xy(k)*xy(k))
5135 
5136 c --- Computation of Gn(alpha), Real and Imaginary part
5137  xdengnx=(rgnx(k-1)-k/x)**2.d+00+ignx(k-1)*ignx(k-1)
5138  rgnx(k)=(k/x-rgnx(k-1))/xdengnx-k/x
5139  ignx(k)=ignx(k-1)/xdengnx
5140 
5141 c --- Computation of An(alpha) and Bn(alpha), Real and Imaginary part
5142  xnum1an=rdny(k)-nr*rdnx(k)
5143  xnum2an=idny(k)+ni*rdnx(k)
5144  xden1an=rdny(k)-nr*rgnx(k)-ni*ignx(k)
5145  xden2an=idny(k)+ni*rgnx(k)-nr*ignx(k)
5146  xdenan=xden1an*xden1an+xden2an*xden2an
5147  ranb=(xnum1an*xden1an+xnum2an*xden2an)/xdenan
5148  ianb=(-xnum1an*xden2an+xnum2an*xden1an)/xdenan
5149  ran(k)=xjonh*(xj(k)*ranb-xy(k)*ianb)
5150  ian(k)=xjonh*(xy(k)*ranb+xj(k)*ianb)
5151 
5152  xnum1bn=nr*rdny(k)+ni*idny(k)-rdnx(k)
5153  xnum2bn=nr*idny(k)-ni*rdny(k)
5154  xden1bn=nr*rdny(k)+ni*idny(k)-rgnx(k)
5155  xden2bn=nr*idny(k)-ni*rdny(k)-ignx(k)
5156  xdenbn=xden1bn*xden1bn+xden2bn*xden2bn
5157  rbnb=(xnum1bn*xden1bn+xnum2bn*xden2bn)/xdenbn
5158  ibnb=(-xnum1bn*xden2bn+xnum2bn*xden1bn)/xdenbn
5159  rbn(k)=xjonh*(xj(k)*rbnb-xy(k)*ibnb)
5160  ibn(k)=xjonh*(xy(k)*rbnb+xj(k)*ibnb)
5161 
5162 c ---Criterion on the recursion formulas as defined by D. Deirmendjian
5163 c et al., J. Opt. Soc. Am., 1961, 51, 6, 620-633
5164  test=(ran(k)**2.+ian(k)**2.+rbn(k)**2.+ibn(k)**2.)/k
5165  if (test.lt.1.0d-14)then
5166  mu=k
5167  goto 400
5168  endif
5169 c --- Computation of the scattering and extinction efficiency factor
5170  xpond=2.d+00/x/x*(2.d+00*k+1)
5171  qsca=qsca+xpond*(ran(k)**2.+ian(k)**2.+rbn(k)**2.+ibn(k)**2.)
5172  qext=qext+xpond*(ran(k)+rbn(k))
5173 
5174  enddo
5175  400 continue
5176 
5177 c --- Computation of the amplitude functions S1 and S2 (cf MIE's theory)
5178 c defined by PIn, TAUn, An and Bn with PIn and TAUn related to the
5179 c Legendre polynomials.
5180  do j=1,nbmu
5181  xmud=cgaus(j)
5182  rs1=0.d+00
5183  rs2=0.d+00
5184  is1=0.d+00
5185  is2=0.d+00
5186  pin(0)=0.d+00
5187  pin(1)=1.d+00
5188  taun(1)=xmud
5189  do k=1,mu
5190  co_n=(2.d+00*k+1.d+00)/k/(k+1.d+00)
5191  rs1=rs1+co_n*(ran(k)*pin(k)+rbn(k)*taun(k))
5192  rs2=rs2+co_n*(ran(k)*taun(k)+rbn(k)*pin(k))
5193  is1=is1+co_n*(ian(k)*pin(k)+ibn(k)*taun(k))
5194  is2=is2+co_n*(ian(k)*taun(k)+ibn(k)*pin(k))
5195  pin(k+1)=((2.d+00*k+1)*xmud*pin(k)-(k+1.d+00)*pin(k-1))/k
5196  taun(k+1)=(k+1.d+00)*xmud*pin(k+1)-(k+2.d+00)*pin(k)
5197  enddo
5198 C --- Computation of the scattering intensity efficiency
5199  p11(j)=2.d+00*(rs1*rs1+is1*is1+rs2*rs2+is2*is2)/x/x
5200  enddo
5201  return
5202  end
5203 
5204  block data aeroso_data
5205  common /sixs_sos/phasel(10,83),cgaus(83),pdgs(83)
5206  real phasel,cgaus,pdgs
5207  data cgaus/
5208  a-1.0000,-0.9996,-0.9976,-0.9942,-0.9893,-0.9828,-0.9749,-0.9655,
5209  a-0.9546,-0.9422,-0.9285,-0.9133,-0.8967,-0.8787,-0.8594,-0.8388,
5210  a-0.8170,-0.7938,-0.7695,-0.7440,-0.7174,-0.6896,-0.6609,-0.6311,
5211  a-0.6003,-0.5687,-0.5361,-0.5028,-0.4687,-0.4339,-0.3984,-0.3623,
5212  a-0.3257,-0.2885,-0.2510,-0.2130,-0.1747,-0.1362,-0.0974,-0.0585,
5213  a-0.0195, 0.0000, 0.0195, 0.0585, 0.0974, 0.1362, 0.1747, 0.2130,
5214  a 0.2510, 0.2885, 0.3257, 0.3623, 0.3984, 0.4339, 0.4687, 0.5028,
5215  a 0.5361, 0.5687, 0.6003, 0.6311, 0.6609, 0.6896, 0.7174, 0.7440,
5216  a 0.7695, 0.7938, 0.8170, 0.8388, 0.8594, 0.8787, 0.8967, 0.9133,
5217  a 0.9285, 0.9422, 0.9546, 0.9655, 0.9749, 0.9828, 0.9893, 0.9942,
5218  a 0.9976, 0.9996, 1.0000/
5219  data pdgs/
5220  a 0.0000, 0.0114, 0.0266, 0.0418, 0.0569, 0.0719, 0.0868, 0.1016,
5221  a 0.1162, 0.1307, 0.1449, 0.1590, 0.1727, 0.1863, 0.1995, 0.2124,
5222  a 0.2251, 0.2373, 0.2492, 0.2606, 0.2719, 0.2826, 0.2929, 0.3027,
5223  a 0.3121, 0.3210, 0.3294, 0.3373, 0.3447, 0.3516, 0.3579, 0.3637,
5224  a 0.3690, 0.3737, 0.3778, 0.3813, 0.3842, 0.3866, 0.3884, 0.3896,
5225  a 0.3902, 0.0000, 0.3902, 0.3896, 0.3884, 0.3866, 0.3842, 0.3813,
5226  a 0.3778, 0.3737, 0.3690, 0.3637, 0.3579, 0.3516, 0.3447, 0.3373,
5227  a 0.3294, 0.3210, 0.3121, 0.3027, 0.2929, 0.2826, 0.2719, 0.2606,
5228  a 0.2492, 0.2373, 0.2251, 0.2124, 0.1995, 0.1863, 0.1727, 0.1590,
5229  a 0.1449, 0.1307, 0.1162, 0.1016, 0.0868, 0.0719, 0.0569, 0.0418,
5230  a 0.0266, 0.0114, 0.0000/
5231  end
5232  subroutine ocea
5233  common /sixs_aerbas/ ph(10,83)
5234  real phr(10,83),ph
5235  integer i,j
5236 c
5237 c model: oceanic
5238 c
5239  DATA ((phr(i,j),j=1,83),i=01,01) /
5240  *0.7855e+00,0.6283e+00,0.5465e+00,0.4693e+00,0.4153e+00,0.3917e+00,
5241  *0.3657e+00,0.3378e+00,0.3161e+00,0.3025e+00,0.2972e+00,0.2990e+00,
5242  *0.3055e+00,0.3118e+00,0.3059e+00,0.2715e+00,0.2118e+00,0.1585e+00,
5243  *0.1230e+00,0.9913e-01,0.8327e-01,0.7292e-01,0.6585e-01,0.6171e-01,
5244  *0.5883e-01,0.5780e-01,0.5791e-01,0.5893e-01,0.6144e-01,0.6406e-01,
5245  *0.6717e-01,0.6966e-01,0.7130e-01,0.7291e-01,0.7434e-01,0.7626e-01,
5246  *0.7847e-01,0.8190e-01,0.8583e-01,0.9044e-01,0.9709e-01,0.1006e+00,
5247  *0.1045e+00,0.1128e+00,0.1239e+00,0.1360e+00,0.1497e+00,0.1667e+00,
5248  *0.1856e+00,0.2070e+00,0.2323e+00,0.2615e+00,0.2948e+00,0.3326e+00,
5249  *0.3772e+00,0.4263e+00,0.4840e+00,0.5492e+00,0.6242e+00,0.7103e+00,
5250  *0.8075e+00,0.9192e+00,0.1046e+01,0.1190e+01,0.1354e+01,0.1541e+01,
5251  *0.1756e+01,0.2002e+01,0.2277e+01,0.2603e+01,0.2976e+01,0.3416e+01,
5252  *0.3931e+01,0.4563e+01,0.5372e+01,0.6490e+01,0.8191e+01,0.1111e+02,
5253  *0.1692e+02,0.3097e+02,0.7524e+02,0.2992e+03,0.1697e+04/
5254  DATA ((phr(i,j),j=1,83),i=02,02) /
5255  *0.7129e+00,0.5739e+00,0.5059e+00,0.4429e+00,0.4035e+00,0.3898e+00,
5256  *0.3678e+00,0.3416e+00,0.3195e+00,0.3042e+00,0.2975e+00,0.2961e+00,
5257  *0.2987e+00,0.2994e+00,0.2909e+00,0.2614e+00,0.2134e+00,0.1670e+00,
5258  *0.1336e+00,0.1100e+00,0.9363e-01,0.8252e-01,0.7480e-01,0.6967e-01,
5259  *0.6621e-01,0.6499e-01,0.6438e-01,0.6506e-01,0.6656e-01,0.6880e-01,
5260  *0.7108e-01,0.7332e-01,0.7497e-01,0.7681e-01,0.7860e-01,0.8093e-01,
5261  *0.8357e-01,0.8723e-01,0.9184e-01,0.9665e-01,0.1036e+00,0.1075e+00,
5262  *0.1112e+00,0.1200e+00,0.1316e+00,0.1436e+00,0.1580e+00,0.1748e+00,
5263  *0.1937e+00,0.2154e+00,0.2413e+00,0.2704e+00,0.3031e+00,0.3421e+00,
5264  *0.3856e+00,0.4356e+00,0.4928e+00,0.5586e+00,0.6333e+00,0.7196e+00,
5265  *0.8188e+00,0.9313e+00,0.1060e+01,0.1208e+01,0.1375e+01,0.1568e+01,
5266  *0.1791e+01,0.2047e+01,0.2340e+01,0.2679e+01,0.3075e+01,0.3547e+01,
5267  *0.4107e+01,0.4805e+01,0.5714e+01,0.6981e+01,0.8889e+01,0.1212e+02,
5268  *0.1839e+02,0.3283e+02,0.7515e+02,0.2626e+03,0.1134e+04/
5269  DATA ((phr(i,j),j=1,83),i=03,03) /
5270  *0.6966e+00,0.5607e+00,0.4902e+00,0.4336e+00,0.3978e+00,0.3866e+00,
5271  *0.3674e+00,0.3412e+00,0.3187e+00,0.3039e+00,0.2960e+00,0.2945e+00,
5272  *0.2960e+00,0.2961e+00,0.2874e+00,0.2591e+00,0.2133e+00,0.1692e+00,
5273  *0.1362e+00,0.1129e+00,0.9630e-01,0.8484e-01,0.7707e-01,0.7190e-01,
5274  *0.6854e-01,0.6653e-01,0.6597e-01,0.6668e-01,0.6812e-01,0.7009e-01,
5275  *0.7216e-01,0.7425e-01,0.7580e-01,0.7758e-01,0.7959e-01,0.8174e-01,
5276  *0.8490e-01,0.8852e-01,0.9294e-01,0.9864e-01,0.1048e+00,0.1084e+00,
5277  *0.1128e+00,0.1220e+00,0.1325e+00,0.1453e+00,0.1596e+00,0.1762e+00,
5278  *0.1959e+00,0.2177e+00,0.2428e+00,0.2725e+00,0.3055e+00,0.3440e+00,
5279  *0.3882e+00,0.4382e+00,0.4953e+00,0.5613e+00,0.6365e+00,0.7225e+00,
5280  *0.8218e+00,0.9344e+00,0.1065e+01,0.1212e+01,0.1381e+01,0.1577e+01,
5281  *0.1801e+01,0.2059e+01,0.2360e+01,0.2701e+01,0.3107e+01,0.3586e+01,
5282  *0.4166e+01,0.4885e+01,0.5821e+01,0.7115e+01,0.9088e+01,0.1241e+02,
5283  *0.1877e+02,0.3323e+02,0.7480e+02,0.2523e+03,0.1018e+04/
5284  DATA ((phr(i,j),j=1,83),i=04,04) /
5285  *0.6774e+00,0.5476e+00,0.4775e+00,0.4252e+00,0.3937e+00,0.3855e+00,
5286  *0.3684e+00,0.3432e+00,0.3209e+00,0.3059e+00,0.2974e+00,0.2950e+00,
5287  *0.2951e+00,0.2935e+00,0.2832e+00,0.2550e+00,0.2114e+00,0.1697e+00,
5288  *0.1380e+00,0.1153e+00,0.9882e-01,0.8737e-01,0.7952e-01,0.7423e-01,
5289  *0.7074e-01,0.6859e-01,0.6788e-01,0.6842e-01,0.6969e-01,0.7150e-01,
5290  *0.7349e-01,0.7557e-01,0.7720e-01,0.7911e-01,0.8125e-01,0.8356e-01,
5291  *0.8685e-01,0.9062e-01,0.9516e-01,0.1010e+00,0.1073e+00,0.1109e+00,
5292  *0.1154e+00,0.1247e+00,0.1352e+00,0.1482e+00,0.1626e+00,0.1793e+00,
5293  *0.1991e+00,0.2210e+00,0.2462e+00,0.2760e+00,0.3091e+00,0.3477e+00,
5294  *0.3920e+00,0.4422e+00,0.4994e+00,0.5656e+00,0.6410e+00,0.7275e+00,
5295  *0.8272e+00,0.9405e+00,0.1071e+01,0.1220e+01,0.1391e+01,0.1588e+01,
5296  *0.1815e+01,0.2077e+01,0.2382e+01,0.2731e+01,0.3145e+01,0.3636e+01,
5297  *0.4233e+01,0.4974e+01,0.5942e+01,0.7282e+01,0.9319e+01,0.1273e+02,
5298  *0.1919e+02,0.3364e+02,0.7414e+02,0.2397e+03,0.8914e+03/
5299  DATA ((phr(i,j),j=1,83),i=05,05) /
5300  *0.6153e+00,0.5058e+00,0.4382e+00,0.3950e+00,0.3738e+00,0.3731e+00,
5301  *0.3585e+00,0.3354e+00,0.3139e+00,0.2983e+00,0.2892e+00,0.2849e+00,
5302  *0.2832e+00,0.2800e+00,0.2703e+00,0.2469e+00,0.2112e+00,0.1741e+00,
5303  *0.1442e+00,0.1219e+00,0.1054e+00,0.9356e-01,0.8531e-01,0.7966e-01,
5304  *0.7561e-01,0.7323e-01,0.7198e-01,0.7214e-01,0.7291e-01,0.7415e-01,
5305  *0.7601e-01,0.7747e-01,0.7901e-01,0.8091e-01,0.8293e-01,0.8564e-01,
5306  *0.8906e-01,0.9289e-01,0.9788e-01,0.1033e+00,0.1102e+00,0.1141e+00,
5307  *0.1181e+00,0.1275e+00,0.1385e+00,0.1511e+00,0.1660e+00,0.1823e+00,
5308  *0.2018e+00,0.2241e+00,0.2491e+00,0.2784e+00,0.3123e+00,0.3503e+00,
5309  *0.3942e+00,0.4451e+00,0.5020e+00,0.5684e+00,0.6448e+00,0.7319e+00,
5310  *0.8325e+00,0.9481e+00,0.1081e+01,0.1234e+01,0.1409e+01,0.1612e+01,
5311  *0.1846e+01,0.2118e+01,0.2440e+01,0.2809e+01,0.3249e+01,0.3773e+01,
5312  *0.4413e+01,0.5211e+01,0.6259e+01,0.7710e+01,0.9888e+01,0.1347e+02,
5313  *0.2009e+02,0.3435e+02,0.7217e+02,0.2130e+03,0.6728e+03/
5314  DATA ((phr(i,j),j=1,83),i=06,06) /
5315  *0.5916e+00,0.4877e+00,0.4171e+00,0.3786e+00,0.3632e+00,0.3654e+00,
5316  *0.3546e+00,0.3335e+00,0.3124e+00,0.2967e+00,0.2869e+00,0.2822e+00,
5317  *0.2792e+00,0.2744e+00,0.2635e+00,0.2413e+00,0.2085e+00,0.1740e+00,
5318  *0.1459e+00,0.1244e+00,0.1084e+00,0.9682e-01,0.8822e-01,0.8243e-01,
5319  *0.7835e-01,0.7606e-01,0.7463e-01,0.7441e-01,0.7473e-01,0.7609e-01,
5320  *0.7739e-01,0.7905e-01,0.8078e-01,0.8256e-01,0.8474e-01,0.8745e-01,
5321  *0.9082e-01,0.9490e-01,0.9996e-01,0.1057e+00,0.1127e+00,0.1166e+00,
5322  *0.1207e+00,0.1301e+00,0.1412e+00,0.1539e+00,0.1686e+00,0.1858e+00,
5323  *0.2048e+00,0.2270e+00,0.2528e+00,0.2818e+00,0.3154e+00,0.3545e+00,
5324  *0.3980e+00,0.4487e+00,0.5067e+00,0.5728e+00,0.6491e+00,0.7374e+00,
5325  *0.8386e+00,0.9547e+00,0.1090e+01,0.1244e+01,0.1423e+01,0.1630e+01,
5326  *0.1870e+01,0.2149e+01,0.2477e+01,0.2862e+01,0.3316e+01,0.3862e+01,
5327  *0.4527e+01,0.5365e+01,0.6458e+01,0.7974e+01,0.1023e+02,0.1390e+02,
5328  *0.2058e+02,0.3459e+02,0.7042e+02,0.1961e+03,0.5608e+03/
5329  DATA ((phr(i,j),j=1,83),i=07,07) /
5330  *0.5164e+00,0.4330e+00,0.3650e+00,0.3341e+00,0.3313e+00,0.3413e+00,
5331  *0.3356e+00,0.3182e+00,0.2998e+00,0.2844e+00,0.2744e+00,0.2677e+00,
5332  *0.2626e+00,0.2560e+00,0.2453e+00,0.2267e+00,0.2009e+00,0.1730e+00,
5333  *0.1485e+00,0.1291e+00,0.1141e+00,0.1028e+00,0.9425e-01,0.8828e-01,
5334  *0.8375e-01,0.8105e-01,0.7927e-01,0.7843e-01,0.7860e-01,0.7925e-01,
5335  *0.8010e-01,0.8165e-01,0.8331e-01,0.8499e-01,0.8754e-01,0.9034e-01,
5336  *0.9390e-01,0.9825e-01,0.1034e+00,0.1093e+00,0.1164e+00,0.1203e+00,
5337  *0.1246e+00,0.1342e+00,0.1452e+00,0.1582e+00,0.1728e+00,0.1896e+00,
5338  *0.2094e+00,0.2310e+00,0.2569e+00,0.2863e+00,0.3195e+00,0.3587e+00,
5339  *0.4030e+00,0.4534e+00,0.5122e+00,0.5794e+00,0.6565e+00,0.7463e+00,
5340  *0.8505e+00,0.9697e+00,0.1109e+01,0.1270e+01,0.1457e+01,0.1674e+01,
5341  *0.1929e+01,0.2226e+01,0.2578e+01,0.2997e+01,0.3495e+01,0.4096e+01,
5342  *0.4831e+01,0.5758e+01,0.6967e+01,0.8629e+01,0.1105e+02,0.1487e+02,
5343  *0.2152e+02,0.3465e+02,0.6548e+02,0.1595e+03,0.3700e+03/
5344  DATA ((phr(i,j),j=1,83),i=08,08) /
5345  *0.3257e+00,0.2888e+00,0.2378e+00,0.2215e+00,0.2345e+00,0.2532e+00,
5346  *0.2578e+00,0.2504e+00,0.2390e+00,0.2282e+00,0.2194e+00,0.2123e+00,
5347  *0.2059e+00,0.1991e+00,0.1906e+00,0.1797e+00,0.1665e+00,0.1520e+00,
5348  *0.1379e+00,0.1254e+00,0.1147e+00,0.1061e+00,0.9917e-01,0.9373e-01,
5349  *0.8960e-01,0.8656e-01,0.8438e-01,0.8306e-01,0.8243e-01,0.8240e-01,
5350  *0.8294e-01,0.8394e-01,0.8543e-01,0.8740e-01,0.8990e-01,0.9302e-01,
5351  *0.9681e-01,0.1013e+00,0.1067e+00,0.1129e+00,0.1200e+00,0.1240e+00,
5352  *0.1283e+00,0.1379e+00,0.1490e+00,0.1618e+00,0.1764e+00,0.1932e+00,
5353  *0.2124e+00,0.2345e+00,0.2599e+00,0.2892e+00,0.3231e+00,0.3622e+00,
5354  *0.4072e+00,0.4593e+00,0.5195e+00,0.5895e+00,0.6711e+00,0.7664e+00,
5355  *0.8781e+00,0.1009e+01,0.1163e+01,0.1343e+01,0.1556e+01,0.1808e+01,
5356  *0.2107e+01,0.2464e+01,0.2891e+01,0.3405e+01,0.4025e+01,0.4779e+01,
5357  *0.5707e+01,0.6863e+01,0.8338e+01,0.1027e+02,0.1291e+02,0.1670e+02,
5358  *0.2248e+02,0.3211e+02,0.5001e+02,0.8772e+02,0.1334e+03/
5359  DATA ((phr(i,j),j=1,83),i=09,09) /
5360  *0.2139e+00,0.1949e+00,0.1618e+00,0.1541e+00,0.1685e+00,0.1828e+00,
5361  *0.1856e+00,0.1800e+00,0.1718e+00,0.1642e+00,0.1581e+00,0.1534e+00,
5362  *0.1495e+00,0.1460e+00,0.1421e+00,0.1375e+00,0.1318e+00,0.1252e+00,
5363  *0.1178e+00,0.1105e+00,0.1036e+00,0.9754e-01,0.9237e-01,0.8811e-01,
5364  *0.8468e-01,0.8198e-01,0.7994e-01,0.7852e-01,0.7768e-01,0.7741e-01,
5365  *0.7767e-01,0.7843e-01,0.7969e-01,0.8144e-01,0.8373e-01,0.8662e-01,
5366  *0.9014e-01,0.9438e-01,0.9939e-01,0.1052e+00,0.1120e+00,0.1158e+00,
5367  *0.1198e+00,0.1289e+00,0.1394e+00,0.1514e+00,0.1653e+00,0.1813e+00,
5368  *0.1997e+00,0.2208e+00,0.2453e+00,0.2736e+00,0.3064e+00,0.3444e+00,
5369  *0.3886e+00,0.4400e+00,0.5000e+00,0.5703e+00,0.6528e+00,0.7502e+00,
5370  *0.8652e+00,0.1001e+01,0.1163e+01,0.1355e+01,0.1584e+01,0.1859e+01,
5371  *0.2188e+01,0.2586e+01,0.3067e+01,0.3649e+01,0.4358e+01,0.5222e+01,
5372  *0.6282e+01,0.7594e+01,0.9235e+01,0.1132e+02,0.1404e+02,0.1768e+02,
5373  *0.2278e+02,0.3033e+02,0.4233e+02,0.6237e+02,0.7953e+02/
5374  DATA ((phr(i,j),j=1,83),i=10,10) /
5375  *0.2110e+00,0.2025e+00,0.1832e+00,0.1730e+00,0.1773e+00,0.1912e+00,
5376  *0.2055e+00,0.2138e+00,0.2152e+00,0.2113e+00,0.2040e+00,0.1946e+00,
5377  *0.1842e+00,0.1734e+00,0.1627e+00,0.1524e+00,0.1429e+00,0.1344e+00,
5378  *0.1268e+00,0.1203e+00,0.1149e+00,0.1104e+00,0.1068e+00,0.1040e+00,
5379  *0.1019e+00,0.1006e+00,0.9982e-01,0.9972e-01,0.1003e+00,0.1014e+00,
5380  *0.1031e+00,0.1054e+00,0.1084e+00,0.1119e+00,0.1162e+00,0.1212e+00,
5381  *0.1271e+00,0.1338e+00,0.1415e+00,0.1503e+00,0.1603e+00,0.1658e+00,
5382  *0.1717e+00,0.1847e+00,0.1995e+00,0.2163e+00,0.2354e+00,0.2571e+00,
5383  *0.2818e+00,0.3100e+00,0.3422e+00,0.3792e+00,0.4216e+00,0.4702e+00,
5384  *0.5261e+00,0.5903e+00,0.6644e+00,0.7500e+00,0.8493e+00,0.9645e+00,
5385  *0.1098e+01,0.1254e+01,0.1436e+01,0.1649e+01,0.1897e+01,0.2189e+01,
5386  *0.2531e+01,0.2934e+01,0.3408e+01,0.3968e+01,0.4630e+01,0.5415e+01,
5387  *0.6348e+01,0.7463e+01,0.8805e+01,0.1044e+02,0.1244e+02,0.1495e+02,
5388  *0.1816e+02,0.2237e+02,0.2799e+02,0.3517e+02,0.3934e+02/
5389  do 1 i=1,10
5390  do 1 j=1,83
5391  ph(i,j)=phr(i,j)
5392  1 continue
5393  return
5394  end
5395  subroutine oda550 (iaer,v,
5396  a taer55)
5397 
5398  double precision bnz,bnz1
5399  common /sixs_atm/ z(34),p(34),t(34),wh(34),wo(34)
5400  common /sixs_del/ delta,sigma
5401  real an5(34),an23(34)
5402  Real v,taer55,z,p,t,wh
5403  Real wo,delta,sigma,dz,bn5,bn51,bn23,bn231,az
5404  Real az1,bz,bz1,ev
5405  Integer iaer,k
5406 c aerosol optical depth at wl=550nm
5407 c vertical repartition of aerosol density for v=23km
5408 c ( in nbr of part/cm3 )
5409 
5410  data an23 /2.828e+03,1.244e+03,5.371e+02,2.256e+02,1.192e+02
5411  a,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
5412  a,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
5413  a,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
5414  a,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
5415  a,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00/
5416 
5417 c vertical repartition of aerosol density for v=5km
5418 c ( in nbr of part/cm3 )
5419 
5420  data an5 /1.378e+04,5.030e+03,1.844e+03,6.731e+02,2.453e+02
5421  a,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
5422  a,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
5423  a,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
5424  a,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
5425  a,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00/
5426 
5427 
5428  taer55=0.
5429 
5430  if(abs(v).le.0.) return
5431  if(iaer.eq.0) return
5432 
5433  do 1 k=1,32
5434  dz=z(k+1)-z(k)
5435  bn5=an5(k)
5436  bn51=an5(k+1)
5437  bn23=an23(k)
5438  bn231=an23(k+1)
5439  az=(115./18.)*(bn5-bn23)
5440  az1=(115./18.)*(bn51-bn231)
5441  bz=(5.*bn5/18.)-(23.*bn23/18.)
5442  bz1=(5.*bn51/18.)-(23.*bn231/18.)
5443  bnz=az/v-bz
5444  bnz1=az1/v-bz1
5445  ev=dz*exp((dlog(bnz)+dlog(bnz1))*.5)
5446  taer55=taer55+ev*sigma*1.0e-03
5447  1 continue
5448  return
5449  end
5450  subroutine odrayl ( wl,
5451  a tray)
5452  double precision a1,a2,a3,a4,awl,an,a
5453  real wl,tray,z,p,t,wh,wo,delta,sigma,pi,ak,dppt,sr
5454  integer k
5455 c molecular optical depth
5456 
5457  common /sixs_atm/ z(34),p(34),t(34),wh(34),wo(34)
5458  common /sixs_del/ delta,sigma
5459  real ns
5460  data pi /3.1415926/
5461  ak=1/wl
5462  awl=wl
5463 c air refraction index edlen 1966 / metrologia,2,71-80 putting pw=0
5464  a1=130.-ak*ak
5465  a2=38.9-ak*ak
5466  a3=2406030./a1
5467  a4=15997./a2
5468  an=(8342.13+a3+a4)*1.0e-08
5469  an=an+1.d+00
5470  a=(24.*pi**3)*((an*an-1.)**2)*(6.+3.*delta)/(6.-7.*delta)
5471  s /((an*an+2.)**2)
5472  tray=0.
5473  do k=1,33
5474  ns=2.54743e+19
5475  dppt=(288.15/1013.25)*(p(k)/t(k)+p(k+1)/t(k+1))/2.
5476  sr=(a*dppt/(awl**4)/ns*1.e+16)*1.e+05
5477  tray=tray+(z(k+1)-z(k))*sr
5478  enddo
5479  return
5480  end
5481  subroutine os (tamoy,trmoy,pizmoy,tamoyp,trmoyp,palt,
5482  s phirad,nt,mu,np,rm,gb,rp,
5483  s xl)
5484 c dimension for gauss integration
5485  integer mu,np
5486  real rm(-mu:mu),gb(-mu:mu),rp(np)
5487 c dimension for os computation
5488  real xl(-mu:mu,np)
5489 c array for sos computation
5490  real xpl(-25:25),psl(-1:80,-25:25),bp(0:25,-25:25),
5491  s xdel(0:30),ydel(0:30),ch(0:30),h(0:30)
5492  real i1(0:30,-25:25),i2(0:30,-25:25),i3(-25:25),
5493  s i4(-25:25),in(-25:25),inm1(-25:25),inm2(-25:25)
5494  real altc(0:30)
5495  Real tamoy,trmoy,pizmoy
5496  Real tamoyp,trmoyp,palt,phirad
5497  Real delta,sigma,pha,betal,hr,ta,tr,trp
5498  Real tap,piz,accu,accu2,ha,xmus,zx,yy,dd,ppp2,ppp1,ca,cr,ratio
5499  Real taup,th,xt1,xt2,pi,phi,aaaa,ron
5500  Real beta0,beta2,roavion0,roavion1,roavion2,roavion,spl,sa1
5501  Real sa2,c,zi1,f,d,xpk,y
5502  Real a1,d1,g1,y1,delta0s
5503  integer snt
5504  integer nt,iwr,iplane,mum1,ntp,j,it,itp,i,l,m,iborm
5505  integer is,isp,ig,k,jj,index
5506  logical ier
5507  common/sixs_del/delta,sigma
5508  common /sixs_trunc/pha(83),betal(0:80)
5509  common/sixs_ier/iwr,ier
5510  double precision xx,xdb,bpjk,bpjmk,z,xi1,xi2,x,xpj,ypk,a,b,ii1,ii2
5511 c the optical thickness above plane are recomputed to give o.t above pla
5512 c write(6,*) 'tamoy,trmoy,tamoyp,trmoyp,palt,pizmoy'
5513 c write(6,*) tamoy,trmoy,tamoyp,trmoyp,palt,pizmoy
5514 c write(6,*) 'betal 0:80'
5515 c do i=0,80
5516 c write(6,*) i,betal(i)
5517 c enddo
5518 c write(6,*) 'phase function 83 terms'
5519 c do i=1,83
5520 c write(6,*) pha(i)
5521 c enddo
5522  snt=nt
5523  hr=8.0
5524  ta=tamoy
5525  tr=trmoy
5526  trp=trmoy-trmoyp
5527  tap=tamoy-tamoyp
5528  piz=pizmoy
5529 c print *, 'ta,tr,piz,tap,trp,palt,nt'
5530 c print *,ta,tr,piz,tap,trp,palt,nt
5531  iplane=0
5532  accu=1.e-20
5533  accu2=1.e-3
5534  mum1=mu-1
5535 c if plane observations recompute scale height for aerosol knowing:
5536 c the aerosol optical depth as measure from the plane = tamoyp
5537 c the rayleigh scale height = = hr (8km)
5538 c the rayleigh optical depth at plane level = trmoyp
5539 c the altitude of the plane = palt
5540 c the rayleigh optical depth for total atmos = trmoy
5541 c the aerosol optical depth for total atmos = tamoy
5542 c if not plane observations then ha is equal to 2.0km
5543 c ntp local variable: if ntp=nt no plane observation selected
5544 c ntp=nt-1 plane observation selected
5545 c it's a mixing rayleigh+aerosol
5546  if(palt.le.900..and.palt.gt.0.0) then
5547  if (tap.gt.1.e-03) then
5548  ha=-palt/log(tap/ta)
5549  else
5550  ha=2.
5551  endif
5552  ntp=nt-1
5553  else
5554  ha=2.0
5555  ntp=nt
5556  endif
5557 c
5558  xmus=-rm(0)
5559 c
5560 c compute mixing rayleigh, aerosol
5561 c case 1: pure rayleigh
5562 c case 2: pure aerosol
5563 c case 3: mixing rayleigh-aerosol
5564 c
5565  if((ta.le.accu2).and.(tr.gt.ta)) then
5566  do j=0,ntp
5567  h(j)=j*tr/ntp
5568  ch(j)=exp(-h(j)/xmus)/2.
5569  ydel(j)=1.0
5570  xdel(j)=0.0
5571  if (j.eq.0) then
5572  altc(j)=300.
5573  else
5574  altc(j)=-log(h(j)/tr)*hr
5575  endif
5576  enddo
5577  endif
5578  if((tr.le.accu2).and.(ta.gt.tr)) then
5579  do j=0,ntp
5580  h(j)=j*ta/ntp
5581  ch(j)=exp(-h(j)/xmus)/2.
5582  ydel(j)=0.0
5583  xdel(j)=piz
5584  if (j.eq.0) then
5585  altc(j)=300.
5586  else
5587  altc(j)=-log(h(j)/ta)*ha
5588  endif
5589  enddo
5590  endif
5591 c
5592  if(tr.gt.accu2.and.ta.gt.accu2)then
5593  ydel(0)=1.0
5594  xdel(0)=0.0
5595  h(0)=0.
5596  ch(0)=0.5
5597  altc(0)=300.
5598  zx=300.
5599  iplane=0
5600  do 14 it=0,ntp
5601  if (it.eq.0) then
5602  yy=0.
5603  dd=0.
5604  goto 111
5605  endif
5606  yy=h(it-1)
5607  dd=ydel(it-1)
5608  111 ppp2=300.0
5609  ppp1=0.0
5610  itp=it
5611  call discre(ta,ha,tr,hr,itp,ntp,yy,dd,ppp2,ppp1,
5612  s zx)
5613  if(ier)return
5614  xx=-zx/ha
5615  if (xx.le.-20) then
5616  ca=0.
5617  else
5618  ca=ta*dexp(xx)
5619  endif
5620  xx=-zx/hr
5621  cr=tr*dexp(xx)
5622  h(it)=cr+ca
5623  altc(it)=zx
5624  ch(it)=exp(-h(it)/xmus)/2.
5625  cr=cr/hr
5626  ca=ca/ha
5627  ratio=cr/(cr+ca)
5628  xdel(it)=(1.e+00-ratio)*piz
5629  ydel(it)=ratio
5630 c print *,'discre ',it,cr,ca,xdel(it),ydel(it),zx
5631  14 continue
5632  endif
5633 c update plane layer if necessary
5634  if (ntp.eq.(nt-1)) then
5635 c compute position of the plane layer
5636  taup=tap+trp
5637  iplane=-1
5638  do i=0,ntp
5639  if (taup.ge.h(i)) iplane=i
5640  enddo
5641 c update the layer from the end to the position to update if necessary
5642  th=0.005
5643  xt1=abs(h(iplane)-taup)
5644  xt2=abs(h(iplane+1)-taup)
5645  if ((xt1.gt.th).and.(xt2.gt.th)) then
5646  do i=nt,iplane+1,-1
5647  xdel(i)=xdel(i-1)
5648  ydel(i)=ydel(i-1)
5649  h(i)=h(i-1)
5650  altc(i)=altc(i-1)
5651  ch(i)=ch(i-1)
5652  enddo
5653  else
5654  nt=ntp
5655  if (xt2.lt.xt1) iplane=iplane+1
5656  endif
5657  h(iplane)=taup
5658  if ( tr.gt.accu2.and.ta.gt.accu2) then
5659  ca=ta*exp(-palt/ha)
5660  cr=tr*exp(-palt/hr)
5661  h(iplane)=ca+cr
5662  cr=cr/hr
5663  ca=ca/ha
5664  ratio=cr/(cr+ca)
5665  xdel(iplane)=(1.e+00-ratio)*piz
5666  ydel(iplane)=ratio
5667  altc(iplane)=palt
5668  ch(iplane)=exp(-h(iplane)/xmus)/2.
5669  endif
5670  if ( tr.gt.accu2.and.ta.le.accu2) then
5671  ydel(iplane)=1.
5672  xdel(iplane)=0.
5673  altc(iplane)=palt
5674  endif
5675  if ( tr.le.accu2.and.ta.gt.accu2) then
5676  ydel(iplane)=0.
5677  xdel(iplane)=1.*piz
5678  altc(iplane)=palt
5679  endif
5680  endif
5681 c
5682 c
5683 c print *,ha,hr,palt,ta,tr,tap,trp
5684 c do i=0,nt
5685 c print *,i,h(i),ch(i),xdel(i),ydel(i),altc(i)
5686 c enddo
5687 c
5688  pi=acos(-1.)
5689  phi=phirad
5690  do 615 l=1,np
5691  do 615 m=-mu,mu
5692  615 xl(m,l)=0.
5693 c
5694 c ************ incident angle mus *******
5695 c
5696 c
5697  aaaa=delta/(2-delta)
5698  ron=(1-aaaa)/(1+2*aaaa)
5699 c write(6,*) 'ron ',ron
5700 c
5701 c rayleigh phase function
5702 c
5703  beta0=1.
5704  beta2=0.5*ron
5705 c
5706 c fourier decomposition
5707 c
5708  do 17 j=-mu,mu
5709  i4(j)=0.
5710  17 continue
5711  iborm=80
5712  if( abs(xmus-1.000000) .lt.1.e-06)iborm=0
5713  do 24 is=0,iborm
5714 c
5715 c primary scattering
5716 c
5717  ig=1
5718  roavion0=0.
5719  roavion1=0.
5720  roavion2=0.
5721  roavion=0.
5722  do 16 j=-mu,mu
5723  i3(j)=0.
5724  16 continue
5725 c
5726 c kernel computations
5727 c
5728  isp=is
5729  call kernel(isp,mu,rm,xpl,psl,bp)
5730  if(is.gt.0)beta0=0.
5731  do 100 j=-mu,mu
5732  if(is-2)200,200,201
5733  200 spl=xpl(0)
5734  sa1=beta0+beta2*xpl(j)*spl
5735  sa2=bp(0,j)
5736  goto 202
5737  201 sa2=bp(0,j)
5738  sa1=0.
5739 c
5740 c primary scattering source function at every level within the layer
5741 c
5742  202 do 101 k=0,nt
5743  c=ch(k)
5744  a=ydel(k)
5745  b=xdel(k)
5746  i2(k,j)=c*(sa2*b+sa1*a)
5747  101 continue
5748  100 continue
5749 c
5750 c vertical integration, primary upward radiation
5751 c
5752 
5753  do 108 k=1,mu
5754  i1(nt,k)=0.
5755  zi1=i1(nt,k)
5756  yy=rm(k)
5757  do 108 i=nt-1,0,-1
5758  jj=i+1
5759  f=h(jj)-h(i)
5760  a=(i2(jj,k)-i2(i,k))/f
5761  b=i2(i,k)-a*h(i)
5762  c=exp(-f/yy)
5763  d=1.0e+00-c
5764  xx=h(i)-h(jj)*c
5765  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
5766  i1(i,k)=zi1
5767  108 continue
5768 c
5769 c vertical integration, primary downward radiation
5770 c
5771  do 109 k=-mu,-1
5772  i1(0,k)=0.
5773  zi1=i1(0,k)
5774  yy=rm(k)
5775  do 109 i=1,nt
5776  jj=i-1
5777  f=h(i)-h(jj)
5778  c=exp(f/yy)
5779  d=1.0e+00-c
5780  a=(i2(i,k)-i2(jj,k))/f
5781  b=i2(i,k)-a*h(i)
5782  xx=h(i)-h(jj)*c
5783  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
5784  i1(i,k)=zi1
5785  109 continue
5786 c
5787 c inm2 is inialized with scattering computed at n-2
5788 c i3 is inialized with primary scattering
5789 c
5790  do 20 k=-mu,mu
5791  if(k) 21,20,23
5792  21 index=nt
5793  go to 25
5794  23 index=0
5795  25 continue
5796  inm1(k)=i1(index,k)
5797  inm2(k)=i1(index,k)
5798  i3(k)=i1(index,k)
5799  20 continue
5800  roavion2=i1(iplane,mu)
5801  roavion=i1(iplane,mu)
5802 c
5803 c loop on successive order
5804 c
5805  503 ig=ig+1
5806 c write(6,*) 'ig ',ig
5807 c
5808 c successive orders
5809 c
5810 c multiple scattering source function at every level within the laye
5811 c
5812 c if is < ou = 2 kernels are a mixing of aerosols and molecules kern
5813 c if is >2 aerosols kernels only
5814 c
5815  if(is-2)210,210,211
5816  210 do455 k=1,mu
5817  xpk=xpl(k)
5818  ypk=xpl(-k)
5819  do 455 i=0,nt
5820  ii1=0.
5821  ii2=0.
5822  x=xdel(i)
5823  y=ydel(i)
5824  do477 j=1,mu
5825  xpj=xpl(j)
5826  z=gb(j)
5827  xi1=i1(i,j)
5828  xi2=i1(i,-j)
5829  bpjk=bp(j,k)*x+y*(beta0+beta2*xpj*xpk)
5830  bpjmk=bp(j,-k)*x+y*(beta0+beta2*xpj*ypk)
5831  xdb=z*(xi1*bpjk+xi2*bpjmk)
5832  ii2=ii2+xdb
5833  xdb=z*(xi1*bpjmk+xi2*bpjk)
5834  ii1=ii1+xdb
5835  477 continue
5836  if (ii2.lt.1.e-30) ii2=0.
5837  if (ii1.lt.1.e-30) ii1=0.
5838  i2(i,k)=ii2
5839  i2(i,-k)=ii1
5840  455 continue
5841  goto 213
5842  211 do45 k=1,mu
5843  do 45 i=0,nt
5844  ii1=0.
5845  ii2=0.
5846  x=xdel(i)
5847  do47 j=1,mu
5848  z=gb(j)
5849  xi1=i1(i,j)
5850  xi2=i1(i,-j)
5851  bpjk=bp(j,k)*x
5852  bpjmk=bp(j,-k)*x
5853  xdb=z*(xi1*bpjk+xi2*bpjmk)
5854  ii2=ii2+xdb
5855  xdb=z*(xi1*bpjmk+xi2*bpjk)
5856  ii1=ii1+xdb
5857  47 continue
5858  if (ii2.lt.1.e-30) ii2=0.
5859  if (ii1.lt.1.e-30) ii1=0.
5860  i2(i,k)=ii2
5861  i2(i,-k)=ii1
5862  45 continue
5863 c
5864 c vertical integration, upward radiation
5865 c
5866  213 do 48 k=1,mu
5867  i1(nt,k)=0.
5868  zi1=i1(nt,k)
5869  yy=rm(k)
5870  do 48 i=nt-1,0,-1
5871  jj=i+1
5872  f=h(jj)-h(i)
5873  a=(i2(jj,k)-i2(i,k))/f
5874  b=i2(i,k)-a*h(i)
5875  c=exp(-f/yy)
5876  d=1.e+00-c
5877  xx=h(i)-h(jj)*c
5878  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
5879  if (abs(zi1).le.1.e-20) zi1=0.
5880  i1(i,k)=zi1
5881  48 continue
5882 c
5883 c vertical integration, downward radiation
5884 c
5885  do 50 k=-mu,-1
5886  i1(0,k)=0.
5887  zi1=i1(0,k)
5888  yy=rm(k)
5889  do 50 i=1,nt
5890  jj=i-1
5891  f=h(i)-h(jj)
5892  c=exp(f/yy)
5893  d=1.e+00-c
5894  a=(i2(i,k)-i2(jj,k))/f
5895  b=i2(i,k)-a*h(i)
5896  xx=h(i)-h(jj)*c
5897  zi1=c*zi1+(d*(b+a*yy)+a*xx)*0.5e+00
5898  if (abs(zi1).le.1.e-20) zi1=0.
5899  i1(i,k)=zi1
5900  50 continue
5901 c
5902 c in is the nieme scattering order
5903 c
5904  do 30 k=-mu,mu
5905  if(k) 31,30,33
5906  31 index=nt
5907  go to 34
5908  33 index=0
5909  34 continue
5910  in(k)=i1(index,k)
5911  30 continue
5912  roavion0=i1(iplane,mu)
5913 c
5914 c convergence test (geometrical serie)
5915 c
5916  if(ig.gt.2) then
5917  z=0.
5918  a1=roavion2
5919  d1=roavion1
5920  g1=roavion0
5921  if(a1.ge.accu.and.d1.ge.accu.and.roavion.ge.accu) then
5922  y=((g1/d1-d1/a1)/((1-g1/d1)**2)*(g1/roavion))
5923  y=abs(y)
5924  z=dmax1(dble(y),z)
5925  endif
5926  do 99 l=-mu,mu
5927  if (l.eq.0) goto 99
5928  a1=inm2(l)
5929  d1=inm1(l)
5930  g1=in(l)
5931  if(a1.le.accu) go to 99
5932  if(d1.le.accu) go to 99
5933  if(i3(l).le.accu) go to 99
5934  y=((g1/d1-d1/a1)/((1-g1/d1)**2)*(g1/i3(l)))
5935  y=abs(y)
5936  z=dmax1(dble(y),z)
5937  99 continue
5938  if(z.lt.0.0001) then
5939 c
5940 c successful test (geometrical serie)
5941 c
5942  do 606 l=-mu,mu
5943  y1=1.
5944  d1=inm1(l)
5945  g1=in(l)
5946  if(d1.le.accu) go to 606
5947  y1=1-g1/d1
5948  if(abs(g1-d1).le.accu) then
5949  go to 606
5950  endif
5951  g1=g1/y1
5952  i3(l)=i3(l)+g1
5953  606 continue
5954  d1=roavion1
5955  g1=roavion0
5956  y1=1.
5957  if(d1.ge.accu) then
5958  if(abs(g1-d1).ge.accu) then
5959  y1=1-g1/d1
5960  g1=g1/y1
5961  endif
5962  roavion=roavion+g1
5963  endif
5964  go to 505
5965  endif
5966 c
5967 c inm2 is the (n-2)ieme scattering order
5968 c
5969  do 26 k=-mu,mu
5970  inm2(k)=inm1(k)
5971  26 continue
5972  roavion2=roavion1
5973  endif
5974 c
5975 c inm1 is the (n-1)ieme scattering order
5976 c
5977  do 27 k=-mu,mu
5978  inm1(k)=in(k)
5979  27 continue
5980  roavion1=roavion0
5981 c
5982 c sum of the n-1 orders
5983 c
5984  do 610 l=-mu,mu
5985  i3(l)=i3(l)+in(l)
5986  610 continue
5987  roavion=roavion+roavion0
5988 c
5989 c stop if order n is less than 1% of the sum
5990 c
5991  z=0.
5992  do 611 l=-mu,mu
5993  if (abs(i3(l)).ge.accu) then
5994  y=abs(in(l)/i3(l))
5995  z=dmax1(z,dble(y))
5996  endif
5997  611 continue
5998  if(z.lt.0.00001) go to 505
5999 c
6000 c stop if order n is greater than 20 in any case
6001 c
6002  if(ig-20) 503,503,505
6003  505 continue
6004 c
6005 c sum of the fourier component s
6006 c
6007  delta0s=1
6008  if(is.ne.0) delta0s=2
6009  do 612 l=-mu,mu
6010  i4(l)=i4(l)+delta0s*i3(l)
6011  612 continue
6012 c
6013 c stop of the fourier decomposition
6014 c
6015  do 614 l=1,np
6016  phi=rp(l)
6017  do 614 m=-mum1,mum1
6018  if(m.gt.0) then
6019  xl(m,l)=xl(m,l)+delta0s*i3(m)*cos(is*(phi+pi))
6020  else
6021  xl(m,l)=xl(m,l)+delta0s*i3(m)*cos(is*phi)
6022  endif
6023  614 continue
6024  if(is.eq.0) then
6025  do k=1,mum1
6026  xl(0,1)=xl(0,1)+rm(k)*gb(k)*i3(-k)
6027  enddo
6028  endif
6029  xl(mu,1)=xl(mu,1)+delta0s*i3(mu)*cos(is*(phirad+pi))
6030  xl(-mu,1)=xl(-mu,1)+delta0s*roavion*cos(is*(phirad+pi))
6031  z=0.
6032  do 613 l=-mu,mu
6033  if (abs(i4(l)).lt.accu) goto 613
6034  x=abs(i3(l)/i4(l))
6035  z=dmax1(z,x)
6036  613 continue
6037  if(z.gt.0.001) go to 24
6038  goto 243
6039  24 continue
6040  243 continue
6041  nt=snt
6042 c write(6,*) 'reflectance ', xl(mu,1)/xmus
6043  return
6044  end
6045  subroutine possol (month,jday,tu,xlon,xlat,
6046  a asol,phi0)
6047 
6048  real tu,xlon,xlat,asol,phi0
6049  integer month,jday,ia,nojour
6050 
6051 c solar position (zenithal angle asol,azimuthal angle phi0
6052 c in degrees)
6053 c jday is the number of the day in the month
6054 
6055  ia = 0
6056  call day_number(jday,month,ia,nojour)
6057 
6058  call pos_fft (nojour, tu, xlon, xlat, asol, phi0)
6059 
6060  if(asol.gt.90) call print_error(
6061  s 'The sun is not raised')
6062  return
6063  end
6064 
6065  subroutine day_number(jday,month,ia,j)
6066  integer jday, month, ia, j
6067 
6068  if (month.le.2) then
6069  j=31*(month-1)+jday
6070  return
6071  endif
6072  if (month.gt.8) then
6073  j=31*(month-1)-((month-2)/2)-2+jday
6074  else
6075  j=31*(month-1)-((month-1)/2)-2+jday
6076  endif
6077  if(ia.ne.0 .and. mod(ia,4).eq.0) j=j+1
6078  return
6079  end
6080 
6081  subroutine pos_fft (j,tu,xlon,xlat,asol,phi0)
6082  real tu, xlat, asol,phi0, tsm, xlon,xla, xj, tet,
6083  a a1, a2, a3, a4, a5, et, tsv, ah, b1, b2, b3, b4,
6084  a b5, b6, b7, delta, amuzero, elev, az, caz, azim, pi2
6085  integer j
6086  parameter (pi=3.14159265,fac=pi/180.)
6087 c solar position (zenithal angle asol,azimuthal angle phi0
6088 c in degrees)
6089 c j is the day number in the year
6090 c
6091 c mean solar time (heure decimale)
6092 
6093  tsm=tu+xlon/15.
6094  xla=xlat*fac
6095  xj=float(j)
6096  tet=2.*pi*xj/365.
6097 
6098 c time equation (in mn.dec)
6099  a1=.000075
6100  a2=.001868
6101  a3=.032077
6102  a4=.014615
6103  a5=.040849
6104  et=a1+a2*cos(tet)-a3*sin(tet)-a4*cos(2.*tet)-a5*sin(2.*tet)
6105  et=et*12.*60./pi
6106 
6107 c true solar time
6108 
6109  tsv=tsm+et/60.
6110  tsv=(tsv-12.)
6111 
6112 c hour angle
6113 
6114  ah=tsv*15.*fac
6115 
6116 c solar declination (in radian)
6117 
6118  b1=.006918
6119  b2=.399912
6120  b3=.070257
6121  b4=.006758
6122  b5=.000907
6123  b6=.002697
6124  b7=.001480
6125  delta=b1-b2*cos(tet)+b3*sin(tet)-b4*cos(2.*tet)+b5*sin(2.*tet)-
6126  &b6*cos(3.*tet)+b7*sin(3.*tet)
6127 
6128 c elevation,azimuth
6129 
6130  amuzero=sin(xla)*sin(delta)+cos(xla)*cos(delta)*cos(ah)
6131  elev=asin(amuzero)
6132  az=cos(delta)*sin(ah)/cos(elev)
6133  if ( (abs(az)-1.000).gt.0.00000) az = sign(1.,az)
6134  caz=(-cos(xla)*sin(delta)+sin(xla)*cos(delta)*cos(ah))/cos(elev)
6135  azim=asin(az)
6136  if(caz.le.0.) azim=pi-azim
6137  if(caz.gt.0.and.az.le.0) azim=2*pi+azim
6138  azim=azim+pi
6139  pi2=2*pi
6140  if(azim.gt.pi2) azim=azim-pi2
6141  elev=elev*180./pi
6142 
6143 c conversion in degrees
6144 
6145  asol=90.-elev
6146  phi0=azim/fac
6147  return
6148  end
6149  subroutine presplane(uw,uo3,xpp,ftray)
6150  real z,p,t,wh,wo,zpl,ppl,tpl,whpl,wopl,xa,xb,xalt
6151  real xtemp,xwo,xwh,g,air,ro3,rt,rp,roair,ds
6152  integer i,isup,iinf,k
6153  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
6154  common /sixs_planesim/zpl(34),ppl(34),tpl(34),whpl(34),wopl(34)
6155  real rmo3(34),rmwh(34)
6156  real ps,xpp,uo3,uw,ftray
6157 
6158 C-- print*,'just get into PRESPLANE.f ...'
6159 C-- do k=1,33
6160 C-- write(6,301) z(k),p(k),t(k),wh(k),wo(k),k
6161 C-- 301 format(1x,'z=',e11.4,1x,'p=',e11.4,1x,'t=',e11.4,1x,
6162 C-- @ 'wh=',e11.4,1x,'wo=',e11.4, 'k=',i3)
6163 C-- end do
6164 
6165 C-- print*,'before interpolating with PRESPLANE.f ...'
6166 C-- do k=1,34
6167 C-- write(6,302) zpl(k),ppl(k),tpl(k),whpl(k),wopl(k),k
6168 C-- 302 format(1x,'zPL=',e11.4,1x,'p=',e11.4,1x,'t=',e11.4,1x,
6169 C-- @ 'wh=',e11.4,1x,'wo=',e11.4, 'k=',i3)
6170 C-- end do
6171 
6172 c log linear interpolation
6173  xpp=xpp+z(1)
6174  if (xpp.ge.100.) xpp=1000.
6175  i=0
6176  10 i=i+1
6177  if (z(i).le.xpp) goto 10
6178  isup=i
6179  iinf=i-1
6180  xa=(z(isup)-z(iinf))/alog(p(isup)/p(iinf))
6181  xb=z(isup)-xa*alog(p(isup))
6182  ps=exp((xpp-xb)/xa)
6183 c interpolating temperature wator vapor and ozone profile versus altitud
6184  xalt=xpp
6185  xtemp=(t(isup)-t(iinf))/(z(isup)-z(iinf))
6186  xtemp=xtemp*(xalt-z(iinf))+t(iinf)
6187  xwo=(wo(isup)-wo(iinf))/(z(isup)-z(iinf))
6188  xwo=xwo*(xalt-z(iinf))+wo(iinf)
6189  xwh=(wh(isup)-wh(iinf))/(z(isup)-z(iinf))
6190  xwh=xwh*(xalt-z(iinf))+wh(iinf)
6191 c uptading atmospheric profile
6192 c last level: plane , complete to 34
6193 c with interpolated layers
6194  do i=1,iinf
6195  zpl(i)=z(i)
6196  ppl(i)=p(i)
6197  tpl(i)=t(i)
6198  whpl(i)=wh(i)
6199  wopl(i)=wo(i)
6200  enddo
6201  zpl(iinf+1)=xalt
6202  ppl(iinf+1)=ps
6203  tpl(iinf+1)=xtemp
6204  whpl(iinf+1)=xwh
6205  wopl(iinf+1)=xwo
6206  do i=iinf+2,34
6207  zpl(i)=zpl(iinf+1)
6208  ppl(i)=ppl(iinf+1)
6209  tpl(i)=tpl(iinf+1)
6210  whpl(i)=whpl(iinf+1)
6211  wopl(i)=wopl(iinf+1)
6212  enddo
6213 c compute modified h2o and o3 integrated content
6214 c compute conversion factor for rayleigh optical thickness computation
6215 c ftray=rp/rt
6216  uw=0.
6217  uo3=0.
6218  g=98.1
6219  air=0.028964/0.0224
6220  ro3=0.048/0.0224
6221  rt=0.
6222  rp=0.
6223  do k=1,33
6224  roair=air*273.16*ppl(k)/(1013.25*tpl(k))
6225  rmwh(k)=wh(k)/(roair*1000.)
6226  rmo3(k)=wo(k)/(roair*1000.)
6227  rt=rt+(p(k+1)/t(k+1)+p(k)/t(k))*(z(k+1)-z(k))
6228  rp=rp+(ppl(k+1)/tpl(k+1)+ppl(k)/tpl(k))*(zpl(k+1)-zpl(k))
6229  enddo
6230  ftray=rp/rt
6231  do k=2,33
6232  ds=(ppl(k-1)-ppl(k))/ppl(1)
6233  uw=uw+((rmwh(k)+rmwh(k-1))/2.)*ds
6234  uo3=uo3+((rmo3(k)+rmo3(k-1))/2.)*ds
6235  enddo
6236  uw=uw*ppl(1)*100./g
6237  uo3=uo3*ppl(1)*100./g
6238  uo3=1000.*uo3/ro3
6239 
6240 C-- print*,'after interpolating with PRESPLANE.f ...'
6241 C-- do k=1,34
6242 C-- write(6,302) zpl(k),ppl(k),tpl(k),whpl(k),wopl(k),k
6243 C-- end do
6244 
6245  return
6246  end
6247  subroutine pressure(uw,uo3,xps)
6248  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
6249  real z,p,t,wh,wo,xa,xb,xalt,xtemp,xwo,xwh,g
6250  real air,ro3,roair,ds
6251  integer i,isup,iinf,l,k
6252  real rmo3(34),rmwh(34)
6253  real ps,xps,uo3,uw
6254 c log linear interpolation
6255 C--- xps=-xps
6256  if (xps.ge.100.) xps=99.99
6257  i=0
6258  10 i=i+1
6259  if (z(i).le.xps) goto 10
6260  isup=i
6261  iinf=i-1
6262  xa=(z(isup)-z(iinf))/alog(p(isup)/p(iinf))
6263  xb=z(isup)-xa*alog(p(isup))
6264  ps=exp((xps-xb)/xa)
6265 c interpolating temperature wator vapor and ozone profile versus altitud
6266  xalt=xps
6267  xtemp=(t(isup)-t(iinf))/(z(isup)-z(iinf))
6268  xtemp=xtemp*(xalt-z(iinf))+t(iinf)
6269  xwo=(wo(isup)-wo(iinf))/(z(isup)-z(iinf))
6270  xwo=xwo*(xalt-z(iinf))+wo(iinf)
6271  xwh=(wh(isup)-wh(iinf))/(z(isup)-z(iinf))
6272  xwh=xwh*(xalt-z(iinf))+wh(iinf)
6273 c uptading atmospheric profile
6274 c 1rst level: target , complete to 34
6275 c with interpolated layers
6276  z(1)=xalt
6277  p(1)=ps
6278  t(1)=xtemp
6279  wh(1)=xwh
6280  wo(1)=xwo
6281  do i=2,33-iinf+1
6282  z(i)=z(i+iinf-1)
6283  p(i)=p(i+iinf-1)
6284  t(i)=t(i+iinf-1)
6285  wh(i)=wh(i+iinf-1)
6286  wo(i)=wo(i+iinf-1)
6287  enddo
6288  l=33-iinf+1
6289  do i=l+1,34
6290  z(i)=(z(34)-z(l))*(i-l)/(34-l)+z(l)
6291  p(i)=(p(34)-p(l))*(i-l)/(34-l)+p(l)
6292  t(i)=(t(34)-t(l))*(i-l)/(34-l)+t(l)
6293  wh(i)=(wh(34)-wh(l))*(i-l)/(34-l)+wh(l)
6294  wo(i)=(wo(34)-wo(l))*(i-l)/(34-l)+wo(l)
6295  enddo
6296 c compute modified h2o and o3 integrated content
6297  uw=0.
6298  uo3=0.
6299  g=98.1
6300  air=0.028964/0.0224
6301  ro3=0.048/0.0224
6302  do k=1,33
6303  roair=air*273.16*p(k)/(1013.25*t(k))
6304  rmwh(k)=wh(k)/(roair*1000.)
6305  rmo3(k)=wo(k)/(roair*1000.)
6306  enddo
6307  do k=2,33
6308  ds=(p(k-1)-p(k))/p(1)
6309  uw=uw+((rmwh(k)+rmwh(k-1))/2.)*ds
6310  uo3=uo3+((rmo3(k)+rmo3(k-1))/2.)*ds
6311  enddo
6312  uw=uw*p(1)*100./g
6313  uo3=uo3*p(1)*100./g
6314  uo3=1000.*uo3/ro3
6315  return
6316  end
6317  subroutine print_error(tex)
6318  character *(*) tex
6319  logical ier
6320  integer iwr
6321  common/sixs_ier/iwr,ier
6322  ier = .true.
6323  write(iwr,'(a)')tex
6324  return
6325  end
6326  subroutine scatra (taer,taerp,tray,trayp,piza,
6327  a palt,nt,mu,rm,gb,xmus,xmuv,
6328  a ddirtt,ddiftt,udirtt,udiftt,sphalbt,
6329  a ddirtr,ddiftr,udirtr,udiftr,sphalbr,
6330  a ddirta,ddifta,udirta,udifta,sphalba)
6331 
6332  integer mu
6333  real rm(-mu:mu),gb(-mu:mu)
6334 c computations of the direct and diffuse transmittances
6335 c for downward and upward paths , and spherical albedo
6336  real xtrans(-1:1)
6337  real taer,taerp,tray,trayp,piza,palt,xmus,xmuv
6338  real udiftt,sphalbt,ddirtr,ddiftr,udirtr,udiftr,sphalbr
6339  real ddirtt,ddiftt,udirtt,ddirta,ddifta,udirta,udifta
6340  real sphalba,tamol,tamolp
6341  integer nt,it
6342 c
6343  ddirtt=1.
6344  ddiftt=0.
6345  udirtt=1.
6346  udiftt=0.
6347  sphalbt=0.
6348  ddirtr=1.
6349  ddiftr=0.
6350  udirtr=1.
6351  udiftr=0.
6352  sphalbr=0.
6353  ddirta=1.
6354  ddifta=0.
6355  udirta=1.
6356  udifta=0.
6357  sphalba=0.
6358 
6359  do 1 it=1,3
6360 c it=1 rayleigh only, it=2 aerosol only, it=3 rayleigh+aerosol
6361  if (it.eq.2.and.taer.le.0.) goto 1
6362 c compute upward,downward diffuse transmittance for rayleigh,aerosol
6363  if (it.eq.1) then
6364  if (palt.gt.900) then
6365  udiftt=(2./3.+xmuv)+(2./3.-xmuv)*exp(-tray/xmuv)
6366  udiftt=udiftt/((4./3.)+tray)-exp(-tray/xmuv)
6367  ddiftt=(2./3.+xmus)+(2./3.-xmus)*exp(-tray/xmus)
6368  ddiftt=ddiftt/((4./3.)+tray)-exp(-tray/xmus)
6369  ddirtt=exp(-tray/xmus)
6370  udirtt=exp(-tray/xmuv)
6371  call csalbr(tray,sphalbt)
6372  endif
6373  if (palt.lt.900) then
6374  tamol=0.
6375  tamolp=0.
6376  rm(-mu)=-xmuv
6377  rm(mu)=xmuv
6378  rm(0)=xmus
6379  call iso(tamol,tray,piza,tamolp,trayp,palt,
6380  a nt,mu,rm,gb,xtrans)
6381  udiftt=xtrans(-1)-exp(-trayp/xmuv)
6382  udirtt=exp(-trayp/xmuv)
6383  rm(-mu)=-xmus
6384  rm(mu)=xmus
6385  rm(0)=xmus
6386  ddiftt=(2./3.+xmus)+(2./3.-xmus)*exp(-tray/xmus)
6387  ddiftt=ddiftt/((4./3.)+tray)-exp(-tray/xmus)
6388  ddirtt=exp(-tray/xmus)
6389  udirtt=exp(-tray/xmuv)
6390  call csalbr(tray,sphalbt)
6391  endif
6392  if (palt.le.0.) then
6393  udiftt=0.
6394  udirtt=1.
6395  endif
6396  endif
6397  if (it.eq.2) then
6398  tamol=0.
6399  tamolp=0.
6400  rm(-mu)=-xmuv
6401  rm(mu)=xmuv
6402  rm(0)=xmus
6403  call iso(taer,tamol,piza,taerp,tamolp,palt,
6404  a nt,mu,rm,gb,xtrans)
6405  udiftt=xtrans(-1)-exp(-taerp/xmuv)
6406  udirtt=exp(-taerp/xmuv)
6407  rm(-mu)=-xmus
6408  rm(mu)=xmus
6409  rm(0)=xmus
6410  call iso(taer,tamol,piza,taerp,tamolp,999.,
6411  a nt,mu,rm,gb,xtrans)
6412  ddirtt=exp(-taer/xmus)
6413  ddiftt=xtrans(1)-exp(-taer/xmus)
6414  sphalbt=xtrans(0)*2.
6415  if (palt.le.0.) then
6416  udiftt=0.
6417  udirtt=1.
6418  endif
6419  endif
6420  if (it.eq.3) then
6421  rm(-mu)=-xmuv
6422  rm(mu)=xmuv
6423  rm(0)=xmus
6424  call iso(taer,tray,piza,taerp,trayp,palt,
6425  a nt,mu,rm,gb,xtrans)
6426  udirtt=exp(-(taerp+trayp)/xmuv)
6427  udiftt=xtrans(-1)-exp(-(taerp+trayp)/xmuv)
6428  rm(-mu)=-xmus
6429  rm(mu)=xmus
6430  rm(0)=xmus
6431  call iso(taer,tray,piza,taerp,trayp,999.,
6432  a nt,mu,rm,gb,xtrans)
6433  ddiftt=xtrans(1)-exp(-(taer+tray)/xmus)
6434  ddirtt=exp(-(taer+tray)/xmus)
6435  sphalbt=xtrans(0)*2.
6436  if (palt.le.0.) then
6437  udiftt=0.
6438  udirtt=1.
6439  endif
6440  endif
6441 c write(6,*) ddirtt,ddiftt,it,tray,taer,trayp,taerp
6442 
6443  if (it.eq.2) goto 2
6444  if (it.eq.3) goto 1
6445  ddirtr=ddirtt
6446  ddiftr=ddiftt
6447  udirtr=udirtt
6448  udiftr=udiftt
6449  sphalbr=sphalbt
6450  goto 1
6451  2 ddirta=ddirtt
6452  ddifta=ddiftt
6453  udirta=udirtt
6454  udifta=udiftt
6455  sphalba=sphalbt
6456  1 continue
6457  return
6458  end
6459  subroutine soot
6460  real ph,phr
6461  integer i,j
6462  common /sixs_aerbas/ ph(10,83)
6463  dimension phr(10,83)
6464 c
6465 c model: soot
6466 c
6467  DATA ((phr(i,j),j=1,83),i=01,01) /
6468  *0.4897e+00,0.4896e+00,0.4890e+00,0.4881e+00,0.4867e+00,0.4849e+00,
6469  *0.4827e+00,0.4802e+00,0.4773e+00,0.4743e+00,0.4709e+00,0.4675e+00,
6470  *0.4638e+00,0.4601e+00,0.4563e+00,0.4526e+00,0.4489e+00,0.4453e+00,
6471  *0.4419e+00,0.4388e+00,0.4359e+00,0.4334e+00,0.4312e+00,0.4296e+00,
6472  *0.4285e+00,0.4281e+00,0.4283e+00,0.4293e+00,0.4312e+00,0.4341e+00,
6473  *0.4380e+00,0.4430e+00,0.4494e+00,0.4571e+00,0.4663e+00,0.4771e+00,
6474  *0.4896e+00,0.5041e+00,0.5206e+00,0.5392e+00,0.5603e+00,0.5717e+00,
6475  *0.5838e+00,0.6101e+00,0.6392e+00,0.6714e+00,0.7069e+00,0.7459e+00,
6476  *0.7886e+00,0.8352e+00,0.8860e+00,0.9411e+00,0.1001e+01,0.1065e+01,
6477  *0.1135e+01,0.1210e+01,0.1290e+01,0.1376e+01,0.1468e+01,0.1566e+01,
6478  *0.1670e+01,0.1781e+01,0.1897e+01,0.2019e+01,0.2148e+01,0.2282e+01,
6479  *0.2421e+01,0.2565e+01,0.2713e+01,0.2865e+01,0.3019e+01,0.3173e+01,
6480  *0.3327e+01,0.3479e+01,0.3625e+01,0.3765e+01,0.3894e+01,0.4011e+01,
6481  *0.4111e+01,0.4192e+01,0.4250e+01,0.4284e+01,0.4292e+01/
6482  DATA ((phr(i,j),j=1,83),i=02,02) /
6483  *0.5620e+00,0.5618e+00,0.5611e+00,0.5599e+00,0.5582e+00,0.5560e+00,
6484  *0.5533e+00,0.5502e+00,0.5467e+00,0.5428e+00,0.5387e+00,0.5342e+00,
6485  *0.5295e+00,0.5246e+00,0.5197e+00,0.5146e+00,0.5096e+00,0.5046e+00,
6486  *0.4998e+00,0.4951e+00,0.4907e+00,0.4866e+00,0.4829e+00,0.4797e+00,
6487  *0.4771e+00,0.4751e+00,0.4738e+00,0.4734e+00,0.4738e+00,0.4753e+00,
6488  *0.4779e+00,0.4817e+00,0.4868e+00,0.4934e+00,0.5016e+00,0.5114e+00,
6489  *0.5231e+00,0.5367e+00,0.5524e+00,0.5704e+00,0.5908e+00,0.6019e+00,
6490  *0.6137e+00,0.6393e+00,0.6678e+00,0.6993e+00,0.7340e+00,0.7720e+00,
6491  *0.8136e+00,0.8589e+00,0.9081e+00,0.9613e+00,0.1019e+01,0.1080e+01,
6492  *0.1147e+01,0.1218e+01,0.1293e+01,0.1373e+01,0.1459e+01,0.1549e+01,
6493  *0.1643e+01,0.1743e+01,0.1847e+01,0.1956e+01,0.2069e+01,0.2185e+01,
6494  *0.2305e+01,0.2428e+01,0.2553e+01,0.2679e+01,0.2806e+01,0.2931e+01,
6495  *0.3055e+01,0.3174e+01,0.3289e+01,0.3396e+01,0.3495e+01,0.3582e+01,
6496  *0.3656e+01,0.3716e+01,0.3758e+01,0.3782e+01,0.3788e+01/
6497  DATA ((phr(i,j),j=1,83),i=03,03) /
6498  *0.5834e+00,0.5832e+00,0.5825e+00,0.5813e+00,0.5795e+00,0.5771e+00,
6499  *0.5743e+00,0.5710e+00,0.5673e+00,0.5632e+00,0.5587e+00,0.5540e+00,
6500  *0.5490e+00,0.5438e+00,0.5384e+00,0.5330e+00,0.5275e+00,0.5221e+00,
6501  *0.5168e+00,0.5117e+00,0.5068e+00,0.5023e+00,0.4981e+00,0.4944e+00,
6502  *0.4913e+00,0.4889e+00,0.4871e+00,0.4862e+00,0.4862e+00,0.4872e+00,
6503  *0.4894e+00,0.4928e+00,0.4975e+00,0.5037e+00,0.5115e+00,0.5210e+00,
6504  *0.5324e+00,0.5457e+00,0.5611e+00,0.5788e+00,0.5988e+00,0.6098e+00,
6505  *0.6215e+00,0.6468e+00,0.6749e+00,0.7061e+00,0.7405e+00,0.7781e+00,
6506  *0.8193e+00,0.8641e+00,0.9127e+00,0.9652e+00,0.1022e+01,0.1083e+01,
6507  *0.1148e+01,0.1217e+01,0.1291e+01,0.1370e+01,0.1453e+01,0.1541e+01,
6508  *0.1633e+01,0.1730e+01,0.1831e+01,0.1936e+01,0.2045e+01,0.2157e+01,
6509  *0.2272e+01,0.2390e+01,0.2509e+01,0.2629e+01,0.2749e+01,0.2867e+01,
6510  *0.2984e+01,0.3096e+01,0.3203e+01,0.3304e+01,0.3395e+01,0.3476e+01,
6511  *0.3545e+01,0.3599e+01,0.3638e+01,0.3660e+01,0.3666e+01/
6512  DATA ((phr(i,j),j=1,83),i=04,04) /
6513  *0.6060e+00,0.6059e+00,0.6051e+00,0.6038e+00,0.6019e+00,0.5994e+00,
6514  *0.5964e+00,0.5929e+00,0.5889e+00,0.5846e+00,0.5798e+00,0.5747e+00,
6515  *0.5693e+00,0.5637e+00,0.5580e+00,0.5521e+00,0.5462e+00,0.5403e+00,
6516  *0.5345e+00,0.5289e+00,0.5235e+00,0.5185e+00,0.5138e+00,0.5096e+00,
6517  *0.5059e+00,0.5029e+00,0.5007e+00,0.4993e+00,0.4988e+00,0.4993e+00,
6518  *0.5010e+00,0.5040e+00,0.5083e+00,0.5142e+00,0.5216e+00,0.5307e+00,
6519  *0.5418e+00,0.5548e+00,0.5699e+00,0.5873e+00,0.6071e+00,0.6180e+00,
6520  *0.6295e+00,0.6546e+00,0.6825e+00,0.7134e+00,0.7474e+00,0.7848e+00,
6521  *0.8255e+00,0.8699e+00,0.9179e+00,0.9698e+00,0.1026e+01,0.1085e+01,
6522  *0.1150e+01,0.1218e+01,0.1290e+01,0.1367e+01,0.1448e+01,0.1534e+01,
6523  *0.1623e+01,0.1717e+01,0.1815e+01,0.1916e+01,0.2020e+01,0.2128e+01,
6524  *0.2237e+01,0.2349e+01,0.2462e+01,0.2576e+01,0.2688e+01,0.2800e+01,
6525  *0.2909e+01,0.3013e+01,0.3113e+01,0.3206e+01,0.3290e+01,0.3364e+01,
6526  *0.3427e+01,0.3477e+01,0.3512e+01,0.3532e+01,0.3537e+01/
6527  DATA ((phr(i,j),j=1,83),i=05,05) /
6528  *0.6604e+00,0.6602e+00,0.6593e+00,0.6578e+00,0.6556e+00,0.6528e+00,
6529  *0.6494e+00,0.6454e+00,0.6409e+00,0.6358e+00,0.6304e+00,0.6245e+00,
6530  *0.6182e+00,0.6117e+00,0.6050e+00,0.5981e+00,0.5911e+00,0.5841e+00,
6531  *0.5771e+00,0.5703e+00,0.5636e+00,0.5573e+00,0.5513e+00,0.5458e+00,
6532  *0.5409e+00,0.5366e+00,0.5331e+00,0.5305e+00,0.5288e+00,0.5281e+00,
6533  *0.5287e+00,0.5305e+00,0.5338e+00,0.5385e+00,0.5450e+00,0.5532e+00,
6534  *0.5633e+00,0.5754e+00,0.5897e+00,0.6062e+00,0.6252e+00,0.6356e+00,
6535  *0.6467e+00,0.6710e+00,0.6980e+00,0.7280e+00,0.7610e+00,0.7972e+00,
6536  *0.8367e+00,0.8797e+00,0.9261e+00,0.9762e+00,0.1030e+01,0.1087e+01,
6537  *0.1149e+01,0.1214e+01,0.1283e+01,0.1355e+01,0.1432e+01,0.1512e+01,
6538  *0.1595e+01,0.1682e+01,0.1772e+01,0.1865e+01,0.1961e+01,0.2058e+01,
6539  *0.2157e+01,0.2257e+01,0.2358e+01,0.2458e+01,0.2557e+01,0.2654e+01,
6540  *0.2748e+01,0.2838e+01,0.2923e+01,0.3001e+01,0.3072e+01,0.3134e+01,
6541  *0.3187e+01,0.3228e+01,0.3257e+01,0.3273e+01,0.3277e+01/
6542  DATA ((phr(i,j),j=1,83),i=06,06) /
6543  *0.6993e+00,0.6991e+00,0.6982e+00,0.6965e+00,0.6942e+00,0.6911e+00,
6544  *0.6874e+00,0.6830e+00,0.6781e+00,0.6726e+00,0.6666e+00,0.6601e+00,
6545  *0.6533e+00,0.6461e+00,0.6387e+00,0.6310e+00,0.6232e+00,0.6154e+00,
6546  *0.6076e+00,0.5998e+00,0.5923e+00,0.5851e+00,0.5782e+00,0.5717e+00,
6547  *0.5659e+00,0.5607e+00,0.5562e+00,0.5526e+00,0.5500e+00,0.5485e+00,
6548  *0.5482e+00,0.5491e+00,0.5515e+00,0.5555e+00,0.5611e+00,0.5686e+00,
6549  *0.5779e+00,0.5893e+00,0.6028e+00,0.6187e+00,0.6369e+00,0.6470e+00,
6550  *0.6577e+00,0.6812e+00,0.7074e+00,0.7366e+00,0.7687e+00,0.8040e+00,
6551  *0.8425e+00,0.8843e+00,0.9295e+00,0.9781e+00,0.1030e+01,0.1086e+01,
6552  *0.1145e+01,0.1208e+01,0.1274e+01,0.1344e+01,0.1417e+01,0.1494e+01,
6553  *0.1573e+01,0.1656e+01,0.1741e+01,0.1828e+01,0.1918e+01,0.2009e+01,
6554  *0.2101e+01,0.2194e+01,0.2287e+01,0.2380e+01,0.2470e+01,0.2559e+01,
6555  *0.2645e+01,0.2726e+01,0.2803e+01,0.2873e+01,0.2937e+01,0.2992e+01,
6556  *0.3038e+01,0.3075e+01,0.3100e+01,0.3115e+01,0.3118e+01/
6557  DATA ((phr(i,j),j=1,83),i=07,07) /
6558  *0.7916e+00,0.7914e+00,0.7903e+00,0.7883e+00,0.7855e+00,0.7818e+00,
6559  *0.7773e+00,0.7721e+00,0.7662e+00,0.7595e+00,0.7522e+00,0.7444e+00,
6560  *0.7360e+00,0.7272e+00,0.7180e+00,0.7085e+00,0.6988e+00,0.6889e+00,
6561  *0.6790e+00,0.6692e+00,0.6595e+00,0.6500e+00,0.6408e+00,0.6321e+00,
6562  *0.6239e+00,0.6164e+00,0.6097e+00,0.6038e+00,0.5989e+00,0.5952e+00,
6563  *0.5926e+00,0.5915e+00,0.5918e+00,0.5936e+00,0.5972e+00,0.6027e+00,
6564  *0.6101e+00,0.6195e+00,0.6311e+00,0.6451e+00,0.6614e+00,0.6705e+00,
6565  *0.6803e+00,0.7017e+00,0.7259e+00,0.7529e+00,0.7828e+00,0.8156e+00,
6566  *0.8514e+00,0.8903e+00,0.9323e+00,0.9774e+00,0.1026e+01,0.1077e+01,
6567  *0.1131e+01,0.1189e+01,0.1249e+01,0.1312e+01,0.1378e+01,0.1447e+01,
6568  *0.1518e+01,0.1590e+01,0.1665e+01,0.1741e+01,0.1819e+01,0.1897e+01,
6569  *0.1976e+01,0.2054e+01,0.2132e+01,0.2209e+01,0.2284e+01,0.2356e+01,
6570  *0.2426e+01,0.2491e+01,0.2552e+01,0.2607e+01,0.2657e+01,0.2700e+01,
6571  *0.2736e+01,0.2764e+01,0.2783e+01,0.2795e+01,0.2797e+01/
6572  DATA ((phr(i,j),j=1,83),i=08,08) /
6573  *0.1041e+01,0.1040e+01,0.1038e+01,0.1036e+01,0.1031e+01,0.1026e+01,
6574  *0.1019e+01,0.1011e+01,0.1002e+01,0.9924e+00,0.9814e+00,0.9694e+00,
6575  *0.9566e+00,0.9431e+00,0.9288e+00,0.9140e+00,0.8988e+00,0.8832e+00,
6576  *0.8673e+00,0.8513e+00,0.8353e+00,0.8194e+00,0.8038e+00,0.7885e+00,
6577  *0.7737e+00,0.7596e+00,0.7462e+00,0.7338e+00,0.7223e+00,0.7121e+00,
6578  *0.7031e+00,0.6955e+00,0.6895e+00,0.6852e+00,0.6827e+00,0.6820e+00,
6579  *0.6833e+00,0.6868e+00,0.6924e+00,0.7003e+00,0.7105e+00,0.7165e+00,
6580  *0.7232e+00,0.7383e+00,0.7559e+00,0.7760e+00,0.7987e+00,0.8240e+00,
6581  *0.8518e+00,0.8821e+00,0.9149e+00,0.9501e+00,0.9877e+00,0.1028e+01,
6582  *0.1069e+01,0.1113e+01,0.1159e+01,0.1207e+01,0.1256e+01,0.1306e+01,
6583  *0.1358e+01,0.1410e+01,0.1463e+01,0.1517e+01,0.1570e+01,0.1623e+01,
6584  *0.1676e+01,0.1727e+01,0.1778e+01,0.1827e+01,0.1873e+01,0.1918e+01,
6585  *0.1960e+01,0.1999e+01,0.2035e+01,0.2067e+01,0.2096e+01,0.2120e+01,
6586  *0.2140e+01,0.2156e+01,0.2167e+01,0.2173e+01,0.2174e+01/
6587  DATA ((phr(i,j),j=1,83),i=09,09) /
6588  *0.1182e+01,0.1181e+01,0.1179e+01,0.1176e+01,0.1171e+01,0.1164e+01,
6589  *0.1156e+01,0.1147e+01,0.1136e+01,0.1124e+01,0.1110e+01,0.1096e+01,
6590  *0.1080e+01,0.1064e+01,0.1046e+01,0.1028e+01,0.1009e+01,0.9903e+00,
6591  *0.9708e+00,0.9510e+00,0.9312e+00,0.9114e+00,0.8919e+00,0.8726e+00,
6592  *0.8539e+00,0.8357e+00,0.8184e+00,0.8019e+00,0.7866e+00,0.7724e+00,
6593  *0.7595e+00,0.7481e+00,0.7383e+00,0.7302e+00,0.7239e+00,0.7195e+00,
6594  *0.7171e+00,0.7168e+00,0.7188e+00,0.7229e+00,0.7294e+00,0.7335e+00,
6595  *0.7382e+00,0.7494e+00,0.7630e+00,0.7790e+00,0.7974e+00,0.8182e+00,
6596  *0.8414e+00,0.8668e+00,0.8944e+00,0.9242e+00,0.9561e+00,0.9898e+00,
6597  *0.1025e+01,0.1063e+01,0.1101e+01,0.1141e+01,0.1183e+01,0.1225e+01,
6598  *0.1268e+01,0.1311e+01,0.1355e+01,0.1399e+01,0.1442e+01,0.1485e+01,
6599  *0.1528e+01,0.1569e+01,0.1609e+01,0.1648e+01,0.1685e+01,0.1720e+01,
6600  *0.1753e+01,0.1783e+01,0.1811e+01,0.1836e+01,0.1858e+01,0.1876e+01,
6601  *0.1891e+01,0.1903e+01,0.1911e+01,0.1916e+01,0.1917e+01/
6602  DATA ((phr(i,j),j=1,83),i=10,10) /
6603  *0.1325e+01,0.1324e+01,0.1322e+01,0.1318e+01,0.1312e+01,0.1304e+01,
6604  *0.1294e+01,0.1283e+01,0.1270e+01,0.1256e+01,0.1240e+01,0.1222e+01,
6605  *0.1204e+01,0.1184e+01,0.1163e+01,0.1142e+01,0.1119e+01,0.1096e+01,
6606  *0.1073e+01,0.1049e+01,0.1025e+01,0.1001e+01,0.9776e+00,0.9541e+00,
6607  *0.9312e+00,0.9088e+00,0.8872e+00,0.8666e+00,0.8471e+00,0.8287e+00,
6608  *0.8118e+00,0.7963e+00,0.7825e+00,0.7704e+00,0.7602e+00,0.7519e+00,
6609  *0.7457e+00,0.7415e+00,0.7396e+00,0.7399e+00,0.7424e+00,0.7446e+00,
6610  *0.7473e+00,0.7545e+00,0.7640e+00,0.7758e+00,0.7899e+00,0.8063e+00,
6611  *0.8248e+00,0.8455e+00,0.8681e+00,0.8928e+00,0.9192e+00,0.9473e+00,
6612  *0.9771e+00,0.1008e+01,0.1041e+01,0.1074e+01,0.1109e+01,0.1144e+01,
6613  *0.1179e+01,0.1215e+01,0.1252e+01,0.1288e+01,0.1324e+01,0.1359e+01,
6614  *0.1393e+01,0.1427e+01,0.1460e+01,0.1491e+01,0.1521e+01,0.1549e+01,
6615  *0.1575e+01,0.1599e+01,0.1622e+01,0.1641e+01,0.1658e+01,0.1673e+01,
6616  *0.1685e+01,0.1694e+01,0.1701e+01,0.1704e+01,0.1705e+01/
6617  do 1 i=1,10
6618  do 1 j=1,83
6619  ph(i,j)=phr(i,j)
6620  1 continue
6621  return
6622  end
6623  subroutine specinterp(wl,taer55,taer55p,
6624  s tamoy,tamoyp,pizmoy,pizmoyp)
6625  real wl,taer55,taer55p,tamoy,tamoyp,pizmoy,pizmoyp,roatm
6626  real dtdir,dtdif,utdir,utdif,sphal,wldis,trayl,traypl
6627  real ext,ome,gasym,phase,pha,betal,phasel,cgaus,pdgs,coef
6628  real wlinf,alphaa,betaa,tsca,coeff
6629  integer linf,ll,lsup,k
6630  common /sixs_disc/ roatm(3,10),dtdir(3,10),dtdif(3,10),
6631  s utdir(3,10),utdif(3,10),sphal(3,10),wldis(10),trayl(10),
6632  s traypl(10)
6633  common /sixs_aer/ext(10),ome(10),gasym(10),phase(10)
6634  common /sixs_trunc/pha(83),betal(0:80)
6635  common /sixs_sos/phasel(10,83),cgaus(83),pdgs(83)
6636  linf=1
6637  do 80 ll=1,9
6638  if(wl.ge.wldis(ll).and.wl.le.wldis(ll+1)) linf=ll
6639  80 continue
6640  if(wl.gt.wldis(10)) linf=9
6641  lsup=linf+1
6642  coef=alog(wldis(lsup)/wldis(linf))
6643  wlinf=wldis(linf)
6644  alphaa=alog(ext(lsup)*ome(lsup)/(ext(linf)*ome(linf)))/coef
6645  betaa=ext(linf)*ome(linf)/(wlinf**(alphaa))
6646  tsca=taer55*betaa*(wl**alphaa)/ext(4)
6647  alphaa=alog(ext(lsup)/(ext(linf)))/coef
6648  betaa=ext(linf)/(wlinf**(alphaa))
6649  tamoy=taer55*betaa*(wl**alphaa)/ext(4)
6650  tamoyp=taer55p*betaa*(wl**alphaa)/ext(4)
6651  pizmoy=tsca/tamoy
6652  pizmoyp=pizmoy
6653  do 81 k=1,83
6654  alphaa=alog(phasel(lsup,k)/phasel(linf,k))/coef
6655  betaa=phasel(linf,k)/(wlinf**(alphaa))
6656  81 pha(k)=betaa*(wl**alphaa)
6657  call trunca(coeff)
6658  tamoy=tamoy*(1.-pizmoy*coeff)
6659  tamoyp=tamoyp*(1.-pizmoyp*coeff)
6660  pizmoy=pizmoy*(1.-coeff)/(1.-pizmoy*coeff)
6661  return
6662  end
6663  subroutine splie2(x2a,ya,m,n,y2a)
6664 
6665  parameter(nn=100)
6666  integer m,n,j,k
6667  real x2a(n),ya(m,n),y2a(m,n),ytmp(nn),y2tmp(nn)
6668  do 13 j=1,m
6669  do 11 k=1,n
6670  ytmp(k)=ya(j,k)
6671 11 continue
6672  call spline(x2a,ytmp,n,1.e30,1.e30,y2tmp)
6673  do 12 k=1,n
6674  y2a(j,k)=y2tmp(k)
6675 12 continue
6676 13 continue
6677  return
6678  end
6679  subroutine splin2(x1a,x2a,ya,y2a,m,n,x1,x2,y)
6680  parameter(nn=100)
6681  integer m,n,j,k
6682  real x1,x2,y
6683  real x1a(m),x2a(n),ya(m,n),y2a(m,n),ytmp(nn),y2tmp(nn)
6684  real yytmp(nn)
6685  do 12 j=1,m
6686  do 11 k=1,n
6687  ytmp(k)=ya(j,k)
6688  y2tmp(k)=y2a(j,k)
6689 11 continue
6690  call splint(x2a,ytmp,y2tmp,n,x2,yytmp(j))
6691 12 continue
6692  call spline(x1a,yytmp,m,1.e30,1.e30,y2tmp)
6693  call splint(x1a,yytmp,y2tmp,m,x1,y)
6694  return
6695  end
6696 
6697  subroutine stm
6698  common/sixs_aerbas/ph(10,83)
6699  real phr(10,83)
6700  real ph
6701  integer i,j
6702 c
6703 c model: Stratospheric aerosol as follow king's model
6704 CJournal of Climate and Applied Meteorology, Vol23, No7, pp=1121-1137, 1984
6705  data ((phr(i,j),j=1,83),i= 1, 1)/
6706  & .4482, .4378, .3984, .3460, .3030, .2864, .3011, .3393,
6707  & .3852, .4224, .4395, .4332, .4068, .3674, .3232, .2806,
6708  & .2436, .2137, .1909, .1740, .1615, .1523, .1453, .1398,
6709  & .1356, .1324, .1300, .1284, .1277, .1278, .1286, .1303,
6710  & .1328, .1362, .1404, .1455, .1515, .1585, .1666, .1759,
6711  & .1864, .1922, .1984, .2119, .2272, .2444, .2638, .2856,
6712  & .3103, .3381, .3696, .4052, .4454, .4911, .5429, .6018,
6713  & .6687, .7447, .8309, .9284, 1.0383, 1.1614, 1.2985, 1.4500,
6714  & 1.6169, 1.8014, 2.0088, 2.2506, 2.5487, 2.9404, 3.4830, 4.2562,
6715  & 5.3583, 6.8944, 8.9537,11.5772,14.7221,18.2338,21.8390,25.1693,
6716  &27.8195,29.4297,29.8220/
6717  data ((phr(i,j),j=1,83),i= 2, 2)/
6718  & .3066, .3025, .2862, .2621, .2369, .2173, .2078, .2095,
6719  & .2201, .2355, .2504, .2607, .2637, .2589, .2472, .2305,
6720  & .2114, .1919, .1736, .1577, .1445, .1340, .1261, .1203,
6721  & .1162, .1134, .1117, .1109, .1108, .1113, .1124, .1141,
6722  & .1165, .1194, .1230, .1273, .1324, .1384, .1452, .1531,
6723  & .1620, .1669, .1722, .1838, .1969, .2117, .2285, .2475,
6724  & .2691, .2936, .3213, .3528, .3886, .4293, .4754, .5278,
6725  & .5872, .6543, .7304, .8164, .9142, 1.0260, 1.1554, 1.3080,
6726  & 1.4922, 1.7208, 2.0120, 2.3907, 2.8891, 3.5464, 4.4062, 5.5124,
6727  & 6.9014, 8.5929,10.5796,12.8175,15.2199,17.6577,19.9678,21.9699,
6728  &23.4901,24.3864,24.6019/
6729  data ((phr(i,j),j=1,83),i= 3, 3)/
6730  & .2797, .2765, .2636, .2440, .2227, .2045, .1934, .1907,
6731  & .1956, .2056, .2171, .2266, .2316, .2310, .2247, .2138,
6732  & .1998, .1843, .1689, .1546, .1422, .1319, .1237, .1176,
6733  & .1131, .1101, .1082, .1073, .1072, .1077, .1089, .1107,
6734  & .1130, .1160, .1196, .1239, .1289, .1347, .1413, .1490,
6735  & .1577, .1625, .1676, .1789, .1916, .2061, .2225, .2410,
6736  & .2621, .2859, .3130, .3437, .3785, .4179, .4626, .5133,
6737  & .5706, .6356, .7094, .7936, .8904, 1.0031, 1.1367, 1.2984,
6738  & 1.4985, 1.7518, 2.0779, 2.5018, 3.0542, 3.7695, 4.6834, 5.8280,
6739  & 7.2258, 8.8822,10.7776,12.8620,15.0519,17.2327,19.2671,21.0083,
6740  &22.3181,23.0858,23.2698/
6741  data ((phr(i,j),j=1,83),i= 4, 4)/
6742  & .2523, .2499, .2401, .2249, .2075, .1914, .1795, .1736,
6743  & .1735, .1782, .1854, .1928, .1984, .2005, .1988, .1932,
6744  & .1846, .1739, .1623, .1506, .1398, .1303, .1223, .1159,
6745  & .1110, .1076, .1054, .1042, .1039, .1044, .1055, .1073,
6746  & .1097, .1127, .1163, .1205, .1255, .1312, .1378, .1453,
6747  & .1539, .1586, .1636, .1746, .1871, .2013, .2173, .2354,
6748  & .2559, .2792, .3055, .3352, .3689, .4070, .4502, .4990,
6749  & .5545, .6178, .6905, .7747, .8738, .9921, 1.1363, 1.3153,
6750  & 1.5410, 1.8295, 2.2003, 2.6770, 3.2861, 4.0549, 5.0090, 6.1680,
6751  & 7.5404, 9.1188,10.8752,12.7575,14.6902,16.5769,18.3076,19.7692,
6752  &20.8579,21.4919,21.6435/
6753  data ((phr(i,j),j=1,83),i= 5, 5)/
6754  & .2099, .2085, .2029, .1937, .1824, .1705, .1597, .1512,
6755  & .1457, .1433, .1435, .1455, .1484, .1511, .1529, .1533,
6756  & .1519, .1489, .1445, .1391, .1331, .1270, .1212, .1158,
6757  & .1112, .1075, .1048, .1029, .1020, .1019, .1027, .1041,
6758  & .1063, .1092, .1128, .1170, .1220, .1278, .1344, .1419,
6759  & .1505, .1551, .1601, .1710, .1833, .1971, .2127, .2303,
6760  & .2501, .2724, .2976, .3260, .3583, .3950, .4371, .4857,
6761  & .5424, .6092, .6892, .7862, .9053, 1.0531, 1.2379, 1.4701,
6762  & 1.7619, 2.1272, 2.5813, 3.1398, 3.8174, 4.6261, 5.5735, 6.6598,
6763  & 7.8763, 9.2034,10.6092,12.0501,13.4719,14.8129,16.0082,16.9948,
6764  &17.7172,18.1334,18.2325/
6765  data ((phr(i,j),j=1,83),i= 6, 6)/
6766  & .1911, .1901, .1861, .1793, .1706, .1610, .1516, .1432,
6767  & .1365, .1318, .1292, .1284, .1289, .1301, .1316, .1328,
6768  & .1333, .1330, .1317, .1295, .1266, .1232, .1196, .1160,
6769  & .1126, .1096, .1072, .1054, .1043, .1040, .1044, .1056,
6770  & .1075, .1102, .1136, .1177, .1227, .1285, .1351, .1427,
6771  & .1513, .1560, .1610, .1719, .1842, .1981, .2136, .2311,
6772  & .2509, .2732, .2986, .3275, .3607, .3992, .4441, .4973,
6773  & .5608, .6374, .7309, .8458, .9877, 1.1636, 1.3815, 1.6506,
6774  & 1.9812, 2.3839, 2.8694, 3.4473, 4.1253, 4.9077, 5.7944, 6.7794,
6775  & 7.8497, 8.9848,10.1567,11.3301,12.4643,13.5152,14.4381,15.1909,
6776  &15.7373,16.0504,16.1247/
6777  data ((phr(i,j),j=1,83),i= 7, 7)/
6778  & .1657, .1652, .1631, .1595, .1546, .1488, .1424, .1358,
6779  & .1294, .1235, .1183, .1141, .1107, .1084, .1070, .1063,
6780  & .1062, .1066, .1072, .1080, .1088, .1096, .1103, .1108,
6781  & .1113, .1117, .1121, .1126, .1133, .1142, .1155, .1172,
6782  & .1193, .1221, .1255, .1296, .1345, .1402, .1469, .1547,
6783  & .1636, .1686, .1739, .1856, .1991, .2147, .2326, .2534,
6784  & .2775, .3058, .3392, .3787, .4256, .4818, .5491, .6299,
6785  & .7270, .8435, .9830, 1.1494, 1.3469, 1.5800, 1.8530, 2.1701,
6786  & 2.5350, 2.9507, 3.4187, 3.9394, 4.5111, 5.1299, 5.7894, 6.4806,
6787  & 7.1921, 7.9098, 8.6176, 9.2978, 9.9320,10.5016,10.9891,11.3786,
6788  &11.6571,11.8152,11.8525/
6789  data ((phr(i,j),j=1,83),i= 8, 8)/
6790  & .1867, .1866, .1860, .1850, .1836, .1819, .1797, .1773,
6791  & .1746, .1717, .1687, .1655, .1624, .1593, .1563, .1535,
6792  & .1509, .1487, .1469, .1455, .1447, .1444, .1449, .1460,
6793  & .1480, .1509, .1547, .1596, .1656, .1729, .1814, .1915,
6794  & .2031, .2164, .2315, .2488, .2683, .2902, .3149, .3426,
6795  & .3736, .3904, .4081, .4466, .4894, .5369, .5895, .6476,
6796  & .7117, .7821, .8593, .9436, 1.0355, 1.1354, 1.2434, 1.3598,
6797  & 1.4848, 1.6183, 1.7604, 1.9108, 2.0693, 2.2352, 2.4081, 2.5870,
6798  & 2.7711, 2.9591, 3.1498, 3.3417, 3.5332, 3.7226, 3.9080, 4.0876,
6799  & 4.2594, 4.4215, 4.5720, 4.7090, 4.8308, 4.9359, 5.0228, 5.0905,
6800  & 5.1379, 5.1645, 5.1708/
6801  data ((phr(i,j),j=1,83),i= 9, 9)/
6802  & .4829, .4828, .4824, .4816, .4804, .4790, .4772, .4751,
6803  & .4728, .4701, .4673, .4643, .4611, .4578, .4544, .4511,
6804  & .4477, .4444, .4413, .4384, .4358, .4335, .4317, .4304,
6805  & .4298, .4299, .4308, .4327, .4356, .4397, .4452, .4520,
6806  & .4605, .4708, .4829, .4971, .5135, .5323, .5536, .5776,
6807  & .6045, .6190, .6344, .6674, .7038, .7435, .7869, .8338,
6808  & .8845, .9390, .9973, 1.0594, 1.1253, 1.1949, 1.2682, 1.3449,
6809  & 1.4249, 1.5080, 1.5939, 1.6823, 1.7728, 1.8650, 1.9584, 2.0527,
6810  & 2.1472, 2.2414, 2.3347, 2.4266, 2.5162, 2.6031, 2.6866, 2.7660,
6811  & 2.8408, 2.9103, 2.9739, 3.0312, 3.0815, 3.1246, 3.1599, 3.1873,
6812  & 3.2064, 3.2170, 3.2195/
6813  data ((phr(i,j),j=1,83),i=10,10)/
6814  & 1.0488, 1.0485, 1.0470, 1.0443, 1.0405, 1.0355, 1.0295, 1.0223,
6815  & 1.0141, 1.0049, .9948, .9838, .9719, .9594, .9461, .9323,
6816  & .9180, .9032, .8882, .8730, .8577, .8425, .8273, .8125,
6817  & .7981, .7841, .7709, .7584, .7469, .7364, .7271, .7191,
6818  & .7126, .7077, .7045, .7031, .7036, .7062, .7109, .7179,
6819  & .7271, .7326, .7387, .7527, .7692, .7881, .8096, .8335,
6820  & .8599, .8886, .9198, .9532, .9888, 1.0265, 1.0661, 1.1075,
6821  & 1.1505, 1.1949, 1.2406, 1.2872, 1.3346, 1.3825, 1.4307, 1.4789,
6822  & 1.5267, 1.5741, 1.6205, 1.6659, 1.7098, 1.7521, 1.7924, 1.8305,
6823  & 1.8661, 1.8989, 1.9289, 1.9557, 1.9792, 1.9992, 2.0156, 2.0282,
6824  & 2.0370, 2.0419, 2.0431/
6825  do 1 i=1,10
6826  do 1 j=1,83
6827  ph(i,j)=phr(i,j)
6828  1 continue
6829  return
6830  end
6831  subroutine subsum
6832  integer i
6833  real z4(34),p4(34),t4(34),wh4(34),wo4(34)
6834  real z,p,t,wh,wo
6835  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
6836 c
6837 c model: subarctique summer mc clatchey
6838 c
6839  data(z4(i),i=1, 34)/
6840  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
6841  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
6842  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
6843  4 35., 40., 45., 50., 70., 100.,99999./
6844  data (p4(i),i=1,34) /
6845  a1.010e+03,8.960e+02,7.929e+02,7.000e+02,6.160e+02,5.410e+02,
6846  a4.730e+02,4.130e+02,3.590e+02,3.107e+02,2.677e+02,2.300e+02,
6847  a1.977e+02,1.700e+02,1.460e+02,1.250e+02,1.080e+02,9.280e+01,
6848  a7.980e+01,6.860e+01,5.890e+01,5.070e+01,4.360e+01,3.750e+01,
6849  a3.227e+01,2.780e+01,1.340e+01,6.610e+00,3.400e+00,1.810e+00,
6850  a9.870e-01,7.070e-02,3.000e-04,0.000e+00/
6851  data (t4(i),i=1,34) /
6852  a2.870e+02,2.820e+02,2.760e+02,2.710e+02,2.660e+02,2.600e+02,
6853  a2.530e+02,2.460e+02,2.390e+02,2.320e+02,2.250e+02,2.250e+02,
6854  a2.250e+02,2.250e+02,2.250e+02,2.250e+02,2.250e+02,2.250e+02,
6855  a2.250e+02,2.250e+02,2.250e+02,2.250e+02,2.250e+02,2.250e+02,
6856  a2.260e+02,2.280e+02,2.350e+02,2.470e+02,2.620e+02,2.740e+02,
6857  a2.770e+02,2.160e+02,2.100e+02,2.100e+02/
6858  data (wh4(i),i=1,34) /
6859  a9.100e+00,6.000e+00,4.200e+00,2.700e+00,1.700e+00,1.000e+00,
6860  a5.400e-01,2.900e-01,1.300e-01,4.200e-02,1.500e-02,9.400e-03,
6861  a6.000e-03,1.800e-03,1.000e-03,7.600e-04,6.400e-04,5.600e-04,
6862  a5.000e-04,4.900e-04,4.500e-04,5.100e-04,5.100e-04,5.400e-04,
6863  a6.000e-04,6.700e-04,3.600e-04,1.100e-04,4.300e-05,1.900e-05,
6864  a6.300e-06,1.400e-07,1.000e-09,0.000e+00/
6865  data (wo4(i),i=1,34) /
6866  a4.900e-05,5.400e-05,5.600e-05,5.800e-05,6.000e-05,6.400e-05,
6867  a7.100e-05,7.500e-05,7.900e-05,1.100e-04,1.300e-04,1.800e-04,
6868  a2.100e-04,2.600e-04,2.800e-04,3.200e-04,3.400e-04,3.900e-04,
6869  a4.100e-04,4.100e-04,3.900e-04,3.600e-04,3.200e-04,3.000e-04,
6870  a2.800e-04,2.600e-04,1.400e-04,9.200e-05,4.100e-05,1.300e-05,
6871  a4.300e-06,8.600e-08,4.300e-11,0.000e+00/
6872  do 1 i=1,34
6873  z(i)=z4(i)
6874  p(i)=p4(i)
6875  t(i)=t4(i)
6876  wh(i)=wh4(i)
6877  wo(i)=wo4(i)
6878  1 continue
6879  return
6880  end
6881  subroutine subwin
6882 
6883  real z5(34),p5(34),t5(34),wh5(34),wo5(34)
6884  real z,p,t,wh,wo
6885  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
6886  integer i
6887 c
6888 c model: subarctique winter mc clatchey
6889 c
6890  data(z5(i),i=1, 34)/
6891  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
6892  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
6893  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
6894  4 35., 40., 45., 50., 70., 100.,99999./
6895  data (p5(i),i=1,34) /
6896  a1.013e+03,8.878e+02,7.775e+02,6.798e+02,5.932e+02,5.158e+02,
6897  a4.467e+02,3.853e+02,3.308e+02,2.829e+02,2.418e+02,2.067e+02,
6898  a1.766e+02,1.510e+02,1.291e+02,1.103e+02,9.431e+01,8.058e+01,
6899  a6.882e+01,5.875e+01,5.014e+01,4.277e+01,3.647e+01,3.109e+01,
6900  a2.649e+01,2.256e+01,1.020e+01,4.701e+00,2.243e+00,1.113e+00,
6901  a5.719e-01,4.016e-02,3.000e-04,0.000e+00/
6902  data (t5(i),i=1,34) /
6903  a2.571e+02,2.591e+02,2.559e+02,2.527e+02,2.477e+02,2.409e+02,
6904  a2.341e+02,2.273e+02,2.206e+02,2.172e+02,2.172e+02,2.172e+02,
6905  a2.172e+02,2.172e+02,2.172e+02,2.172e+02,2.166e+02,2.160e+02,
6906  a2.154e+02,2.148e+02,2.141e+02,2.136e+02,2.130e+02,2.124e+02,
6907  a2.118e+02,2.112e+02,2.160e+02,2.222e+02,2.347e+02,2.470e+02,
6908  a2.593e+02,2.457e+02,2.100e+02,2.100e+02/
6909  data (wh5(i),i=1,34) /
6910  a1.200e+00,1.200e+00,9.400e-01,6.800e-01,4.100e-01,2.000e-01,
6911  a9.800e-02,5.400e-02,1.100e-02,8.400e-03,5.500e-03,3.800e-03,
6912  a2.600e-03,1.800e-03,1.000e-03,7.600e-04,6.400e-04,5.600e-04,
6913  a5.000e-04,4.900e-04,4.500e-04,5.100e-04,5.100e-04,5.400e-04,
6914  a6.000e-04,6.700e-04,3.600e-04,1.100e-04,4.300e-05,1.900e-05,
6915  a6.300e-06,1.400e-07,1.000e-09,0.000e+00/
6916  data (wo5(i),i=1,34) /
6917  a4.100e-05,4.100e-05,4.100e-05,4.300e-05,4.500e-05,4.700e-05,
6918  a4.900e-05,7.100e-05,9.000e-05,1.600e-04,2.400e-04,3.200e-04,
6919  a4.300e-04,4.700e-04,4.900e-04,5.600e-04,6.200e-04,6.200e-04,
6920  a6.200e-04,6.000e-04,5.600e-04,5.100e-04,4.700e-04,4.300e-04,
6921  a3.600e-04,3.200e-04,1.500e-04,9.200e-05,4.100e-05,1.300e-05,
6922  a4.300e-06,8.600e-08,4.300e-11,0.000e+00/
6923  do 1 i=1,34
6924  z(i)=z5(i)
6925  p(i)=p5(i)
6926  t(i)=t5(i)
6927  wh(i)=wh5(i)
6928  wo(i)=wo5(i)
6929  1 continue
6930  return
6931  end
6932  subroutine tropic
6933  integer i
6934  real z1(34),p1(34),t1(34),wh1(34),wo1(34)
6935  real z,p,t,wh,wo
6936  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
6937 c
6938 c model: tropical mc clatchey
6939 c
6940  data(z1(i),i=1, 34)/
6941  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
6942  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
6943  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
6944  4 35., 40., 45., 50., 70., 100.,99999./
6945  data (p1(i),i=1,34)/
6946  a1.013e+03,9.040e+02,8.050e+02,7.150e+02,6.330e+02,5.590e+02,
6947  a4.920e+02,4.320e+02,3.780e+02,3.290e+02,2.860e+02,2.470e+02,
6948  a2.130e+02,1.820e+02,1.560e+02,1.320e+02,1.110e+02,9.370e+01,
6949  a7.890e+01,6.660e+01,5.650e+01,4.800e+01,4.090e+01,3.500e+01,
6950  a3.000e+01,2.570e+01,1.220e+01,6.000e+00,3.050e+00,1.590e+00,
6951  a8.540e-01,5.790e-02,3.000e-04,0.000e+00/
6952  data (t1(i),i=1,34)/
6953  a3.000e+02,2.940e+02,2.880e+02,2.840e+02,2.770e+02,2.700e+02,
6954  a2.640e+02,2.570e+02,2.500e+02,2.440e+02,2.370e+02,2.300e+02,
6955  a2.240e+02,2.170e+02,2.100e+02,2.040e+02,1.970e+02,1.950e+02,
6956  a1.990e+02,2.030e+02,2.070e+02,2.110e+02,2.150e+02,2.170e+02,
6957  a2.190e+02,2.210e+02,2.320e+02,2.430e+02,2.540e+02,2.650e+02,
6958  a2.700e+02,2.190e+02,2.100e+02,2.100e+02/
6959  data (wh1(i),i=1,34)/
6960  a1.900e+01,1.300e+01,9.300e+00,4.700e+00,2.200e+00,1.500e+00,
6961  a8.500e-01,4.700e-01,2.500e-01,1.200e-01,5.000e-02,1.700e-02,
6962  a6.000e-03,1.800e-03,1.000e-03,7.600e-04,6.400e-04,5.600e-04,
6963  a5.000e-04,4.900e-04,4.500e-04,5.100e-04,5.100e-04,5.400e-04,
6964  a6.000e-04,6.700e-04,3.600e-04,1.100e-04,4.300e-05,1.900e-05,
6965  a6.300e-06,1.400e-07,1.000e-09,0.000e+00/
6966  data (wo1(i),i=1,34)/
6967  a5.600e-05,5.600e-05,5.400e-05,5.100e-05,4.700e-05,4.500e-05,
6968  a4.300e-05,4.100e-05,3.900e-05,3.900e-05,3.900e-05,4.100e-05,
6969  a4.300e-05,4.500e-05,4.500e-05,4.700e-05,4.700e-05,6.900e-05,
6970  a9.000e-05,1.400e-04,1.900e-04,2.400e-04,2.800e-04,3.200e-04,
6971  a3.400e-04,3.400e-04,2.400e-04,9.200e-05,4.100e-05,1.300e-05,
6972  a4.300e-06,8.600e-08,4.300e-11,0.000e+00/
6973  do 1 i=1,34
6974  z(i)=z1(i)
6975  p(i)=p1(i)
6976  t(i)=t1(i)
6977  wh(i)=wh1(i)
6978  wo(i)=wo1(i)
6979  1 continue
6980  return
6981  end
6982  subroutine trunca(coeff)
6983  real aa,x1,x2,a,x,rm,z1
6984  real cosang(80),weight(80),ptemp(83),pl(-1:81)
6985  real rmu(83),ga(83)
6986  integer nbmu,nang,k,j,kk,i
6987  real pha,betal,coeff
6988  common /sixs_trunc/pha(1:83),betal(0:80)
6989  nbmu=83
6990  nang=80
6991  do k=1,nbmu
6992  ptemp(k)=pha(k)
6993  enddo
6994  call gauss(-1.,1.,cosang,weight,nang)
6995  do 1 j=1,40
6996  rmu(j+1)=cosang(j)
6997  ga(j+1)=weight(j)
6998  1 continue
6999  rmu(1)=-1.0
7000  ga(1)=0.
7001  rmu(42)=0.
7002  ga(42)=0.
7003  do 2 j=41,80
7004  rmu(j+2)=cosang(j)
7005  ga(j+2)=weight(j)
7006  2 continue
7007  rmu(83)=1.0
7008  ga(83)=0.
7009  do 3 j=1,nbmu
7010  if((rmu(j).gt.0.8)) then
7011  go to 20
7012  else
7013  k=j-1
7014  endif
7015  3 continue
7016  20 continue
7017  do 4 j=1,nbmu
7018  if((rmu(j).gt.0.94)) then
7019  go to 21
7020  else
7021  kk=j-1
7022  endif
7023  4 continue
7024  21 continue
7025  aa=(alog10(pha(kk))-alog10(pha(k)))/
7026  a (acos(rmu(kk))-acos(rmu(k)))
7027  x1=alog10(pha(kk))
7028  x2=acos(rmu(kk))
7029  do 5 j=kk+1,nbmu
7030  if(abs(rmu(j)-1.).le.1d-08) a=x1-aa*x2
7031  a=x1+aa*(acos(rmu(j))-x2)
7032  ptemp(j)=10**a
7033  5 continue
7034  do i=1,83
7035  pha(i)=ptemp(i)
7036  enddo
7037 c
7038  do 10 k=0,80
7039  betal(k)=0.
7040  10 continue
7041  do 11 j=1,83
7042  x=pha(j)*ga(j)
7043  rm=rmu(j)
7044  pl(-1)=0.
7045  pl(0)=1.
7046  do 12 k=0,80
7047  pl(k+1)=((2*k+1.)*rm*pl(k)-k*pl(k-1))/(k+1.)
7048  betal(k)=betal(k)+x*pl(k)
7049  12 continue
7050  11 continue
7051  do 13 k=0,80
7052  betal(k)=(2*k+1.)*0.5*betal(k)
7053  13 continue
7054  z1=betal(0)
7055  coeff=1.-z1
7056  do k=0,80
7057  betal(k)=betal(k)/z1
7058  enddo
7059  return
7060  end
7061  subroutine us62
7062 
7063  integer i
7064  real z6(34),p6(34),t6(34),wh6(34),wo6(34)
7065  real z,p,t,wh,wo
7066  common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
7067 c
7068 c model: us standard 62 mc clatchey
7069 c
7070  data(z6(i),i=1, 34)/
7071  1 0., 1., 2., 3., 4., 5., 6., 7., 8.,
7072  2 9., 10., 11., 12., 13., 14., 15., 16., 17.,
7073  3 18., 19., 20., 21., 22., 23., 24., 25., 30.,
7074  4 35., 40., 45., 50., 70., 100.,99999./
7075  data (p6(i),i=1,34) /
7076  a1.013e+03,8.986e+02,7.950e+02,7.012e+02,6.166e+02,5.405e+02,
7077  a4.722e+02,4.111e+02,3.565e+02,3.080e+02,2.650e+02,2.270e+02,
7078  a1.940e+02,1.658e+02,1.417e+02,1.211e+02,1.035e+02,8.850e+01,
7079  a7.565e+01,6.467e+01,5.529e+01,4.729e+01,4.047e+01,3.467e+01,
7080  a2.972e+01,2.549e+01,1.197e+01,5.746e+00,2.871e+00,1.491e+00,
7081  a7.978e-01,5.520e-02,3.008e-04,0.000e+00/
7082  data (t6(i),i=1,34) /
7083  a2.881e+02,2.816e+02,2.751e+02,2.687e+02,2.622e+02,2.557e+02,
7084  a2.492e+02,2.427e+02,2.362e+02,2.297e+02,2.232e+02,2.168e+02,
7085  a2.166e+02,2.166e+02,2.166e+02,2.166e+02,2.166e+02,2.166e+02,
7086  a2.166e+02,2.166e+02,2.166e+02,2.176e+02,2.186e+02,2.196e+02,
7087  a2.206e+02,2.216e+02,2.265e+02,2.365e+02,2.534e+02,2.642e+02,
7088  a2.706e+02,2.197e+02,2.100e+02,2.100e+02/
7089  data (wh6(i),i=1,34) /
7090  a5.900e+00,4.200e+00,2.900e+00,1.800e+00,1.100e+00,6.400e-01,
7091  a3.800e-01,2.100e-01,1.200e-01,4.600e-02,1.800e-02,8.200e-03,
7092  a3.700e-03,1.800e-03,8.400e-04,7.200e-04,6.100e-04,5.200e-04,
7093  a4.400e-04,4.400e-04,4.400e-04,4.800e-04,5.200e-04,5.700e-04,
7094  a6.100e-04,6.600e-04,3.800e-04,1.600e-04,6.700e-05,3.200e-05,
7095  a1.200e-05,1.500e-07,1.000e-09,0.000e+00/
7096  data (wo6(i),i=1,34) /
7097  a5.400e-05,5.400e-05,5.400e-05,5.000e-05,4.600e-05,4.600e-05,
7098  a4.500e-05,4.900e-05,5.200e-05,7.100e-05,9.000e-05,1.300e-04,
7099  a1.600e-04,1.700e-04,1.900e-04,2.100e-04,2.400e-04,2.800e-04,
7100  a3.200e-04,3.500e-04,3.800e-04,3.800e-04,3.900e-04,3.800e-04,
7101  a3.600e-04,3.400e-04,2.000e-04,1.100e-04,4.900e-05,1.700e-05,
7102  a4.000e-06,8.600e-08,4.300e-11,0.000e+00/
7103  do 1 i=1,34
7104  z(i)=z6(i)
7105  p(i)=p6(i)
7106  t(i)=t6(i)
7107  wh(i)=wh6(i)
7108  wo(i)=wo6(i)
7109  1 continue
7110  return
7111  end
7112  subroutine varsol (jday,month,
7113  a dsol)
7114 
7115  real dsol,pi,om
7116  integer jday,month,j
7117 
7118 c calculation of the variability of the solar constant during the
7119 c year.
7120 c jday is the number of the day in the month
7121 c dsol is a multiplicative factor to apply to the mean value of
7122 c solar constant
7123 
7124  if (month.le.2) goto 1
7125  if (month.gt.8) goto 2
7126  j=31*(month-1)-((month-1)/2)-2+jday
7127  goto 3
7128  1 j=31*(month-1)+jday
7129  goto 3
7130  2 j=31*(month-1)-((month-2)/2)-2+jday
7131 
7132  3 pi=2.*acos(0.)
7133  om=(.9856*float(j-4))*pi/180.
7134  dsol=1./((1.-.01673*cos(om))**2)
7135  return
7136  end
7137  subroutine wate
7138  integer i,j
7139  real phr(10,83)
7140  real ph
7141  common /sixs_aerbas/ ph(10,83)
7142 c
7143 c model: water-soluble
7144 c
7145  DATA ((phr(i,j),j=1,83),i=01,01) /
7146  *0.4115e+00,0.4045e+00,0.3805e+00,0.3495e+00,0.3192e+00,0.2943e+00,
7147  *0.2768e+00,0.2659e+00,0.2592e+00,0.2538e+00,0.2479e+00,0.2411e+00,
7148  *0.2336e+00,0.2255e+00,0.2175e+00,0.2098e+00,0.2026e+00,0.1961e+00,
7149  *0.1903e+00,0.1854e+00,0.1812e+00,0.1778e+00,0.1752e+00,0.1734e+00,
7150  *0.1723e+00,0.1719e+00,0.1724e+00,0.1736e+00,0.1756e+00,0.1784e+00,
7151  *0.1820e+00,0.1866e+00,0.1920e+00,0.1985e+00,0.2061e+00,0.2149e+00,
7152  *0.2249e+00,0.2363e+00,0.2492e+00,0.2638e+00,0.2803e+00,0.2893e+00,
7153  *0.2988e+00,0.3195e+00,0.3428e+00,0.3688e+00,0.3979e+00,0.4306e+00,
7154  *0.4671e+00,0.5079e+00,0.5537e+00,0.6048e+00,0.6622e+00,0.7264e+00,
7155  *0.7985e+00,0.8794e+00,0.9701e+00,0.1072e+01,0.1186e+01,0.1315e+01,
7156  *0.1460e+01,0.1622e+01,0.1805e+01,0.2011e+01,0.2242e+01,0.2503e+01,
7157  *0.2796e+01,0.3125e+01,0.3496e+01,0.3913e+01,0.4383e+01,0.4912e+01,
7158  *0.5510e+01,0.6185e+01,0.6951e+01,0.7825e+01,0.8828e+01,0.9991e+01,
7159  *0.1136e+02,0.1297e+02,0.1491e+02,0.1711e+02,0.1834e+02/
7160  DATA ((phr(i,j),j=1,83),i=02,02) /
7161  *0.3918e+00,0.3859e+00,0.3654e+00,0.3384e+00,0.3117e+00,0.2895e+00,
7162  *0.2736e+00,0.2635e+00,0.2571e+00,0.2522e+00,0.2470e+00,0.2411e+00,
7163  *0.2345e+00,0.2275e+00,0.2204e+00,0.2135e+00,0.2071e+00,0.2012e+00,
7164  *0.1959e+00,0.1914e+00,0.1875e+00,0.1844e+00,0.1820e+00,0.1804e+00,
7165  *0.1794e+00,0.1792e+00,0.1797e+00,0.1810e+00,0.1831e+00,0.1860e+00,
7166  *0.1898e+00,0.1945e+00,0.2001e+00,0.2068e+00,0.2146e+00,0.2236e+00,
7167  *0.2339e+00,0.2456e+00,0.2589e+00,0.2739e+00,0.2909e+00,0.3001e+00,
7168  *0.3099e+00,0.3312e+00,0.3552e+00,0.3820e+00,0.4119e+00,0.4455e+00,
7169  *0.4830e+00,0.5249e+00,0.5718e+00,0.6243e+00,0.6829e+00,0.7486e+00,
7170  *0.8221e+00,0.9045e+00,0.9968e+00,0.1100e+01,0.1216e+01,0.1346e+01,
7171  *0.1492e+01,0.1655e+01,0.1839e+01,0.2045e+01,0.2275e+01,0.2534e+01,
7172  *0.2824e+01,0.3149e+01,0.3513e+01,0.3920e+01,0.4375e+01,0.4884e+01,
7173  *0.5454e+01,0.6092e+01,0.6807e+01,0.7611e+01,0.8516e+01,0.9543e+01,
7174  *0.1071e+02,0.1205e+02,0.1357e+02,0.1518e+02,0.1599e+02/
7175  DATA ((phr(i,j),j=1,83),i=03,03) /
7176  *0.3872e+00,0.3816e+00,0.3620e+00,0.3360e+00,0.3102e+00,0.2887e+00,
7177  *0.2732e+00,0.2633e+00,0.2571e+00,0.2522e+00,0.2471e+00,0.2414e+00,
7178  *0.2350e+00,0.2283e+00,0.2214e+00,0.2148e+00,0.2085e+00,0.2028e+00,
7179  *0.1976e+00,0.1932e+00,0.1894e+00,0.1864e+00,0.1840e+00,0.1824e+00,
7180  *0.1815e+00,0.1813e+00,0.1819e+00,0.1832e+00,0.1853e+00,0.1883e+00,
7181  *0.1920e+00,0.1968e+00,0.2024e+00,0.2092e+00,0.2170e+00,0.2261e+00,
7182  *0.2364e+00,0.2483e+00,0.2617e+00,0.2768e+00,0.2939e+00,0.3032e+00,
7183  *0.3131e+00,0.3346e+00,0.3587e+00,0.3857e+00,0.4159e+00,0.4497e+00,
7184  *0.4875e+00,0.5297e+00,0.5769e+00,0.6297e+00,0.6887e+00,0.7547e+00,
7185  *0.8286e+00,0.9114e+00,0.1004e+01,0.1108e+01,0.1224e+01,0.1354e+01,
7186  *0.1500e+01,0.1664e+01,0.1847e+01,0.2053e+01,0.2284e+01,0.2542e+01,
7187  *0.2831e+01,0.3154e+01,0.3515e+01,0.3919e+01,0.4370e+01,0.4874e+01,
7188  *0.5436e+01,0.6064e+01,0.6765e+01,0.7549e+01,0.8430e+01,0.9422e+01,
7189  *0.1054e+02,0.1182e+02,0.1324e+02,0.1472e+02,0.1544e+02/
7190  DATA ((phr(i,j),j=1,83),i=04,04) /
7191  *0.3737e+00,0.3687e+00,0.3509e+00,0.3269e+00,0.3030e+00,0.2830e+00,
7192  *0.2686e+00,0.2593e+00,0.2535e+00,0.2490e+00,0.2444e+00,0.2393e+00,
7193  *0.2335e+00,0.2273e+00,0.2210e+00,0.2148e+00,0.2089e+00,0.2036e+00,
7194  *0.1987e+00,0.1945e+00,0.1910e+00,0.1881e+00,0.1859e+00,0.1844e+00,
7195  *0.1836e+00,0.1835e+00,0.1842e+00,0.1855e+00,0.1877e+00,0.1907e+00,
7196  *0.1945e+00,0.1993e+00,0.2051e+00,0.2118e+00,0.2198e+00,0.2289e+00,
7197  *0.2394e+00,0.2513e+00,0.2649e+00,0.2802e+00,0.2974e+00,0.3068e+00,
7198  *0.3168e+00,0.3385e+00,0.3628e+00,0.3901e+00,0.4206e+00,0.4547e+00,
7199  *0.4928e+00,0.5353e+00,0.5829e+00,0.6361e+00,0.6955e+00,0.7620e+00,
7200  *0.8363e+00,0.9195e+00,0.1013e+01,0.1117e+01,0.1233e+01,0.1364e+01,
7201  *0.1510e+01,0.1674e+01,0.1858e+01,0.2063e+01,0.2293e+01,0.2550e+01,
7202  *0.2838e+01,0.3160e+01,0.3518e+01,0.3919e+01,0.4365e+01,0.4863e+01,
7203  *0.5416e+01,0.6033e+01,0.6719e+01,0.7483e+01,0.8337e+01,0.9292e+01,
7204  *0.1036e+02,0.1156e+02,0.1289e+02,0.1423e+02,0.1486e+02/
7205  DATA ((phr(i,j),j=1,83),i=05,05) /
7206  *0.3651e+00,0.3607e+00,0.3449e+00,0.3233e+00,0.3016e+00,0.2832e+00,
7207  *0.2697e+00,0.2609e+00,0.2552e+00,0.2509e+00,0.2465e+00,0.2418e+00,
7208  *0.2364e+00,0.2307e+00,0.2249e+00,0.2191e+00,0.2137e+00,0.2086e+00,
7209  *0.2041e+00,0.2001e+00,0.1968e+00,0.1940e+00,0.1919e+00,0.1905e+00,
7210  *0.1898e+00,0.1897e+00,0.1904e+00,0.1919e+00,0.1941e+00,0.1971e+00,
7211  *0.2011e+00,0.2059e+00,0.2118e+00,0.2187e+00,0.2267e+00,0.2361e+00,
7212  *0.2467e+00,0.2589e+00,0.2727e+00,0.2883e+00,0.3059e+00,0.3155e+00,
7213  *0.3257e+00,0.3478e+00,0.3726e+00,0.4004e+00,0.4315e+00,0.4662e+00,
7214  *0.5050e+00,0.5483e+00,0.5967e+00,0.6507e+00,0.7110e+00,0.7783e+00,
7215  *0.8536e+00,0.9376e+00,0.1032e+01,0.1137e+01,0.1254e+01,0.1385e+01,
7216  *0.1531e+01,0.1695e+01,0.1878e+01,0.2083e+01,0.2311e+01,0.2566e+01,
7217  *0.2850e+01,0.3166e+01,0.3518e+01,0.3910e+01,0.4344e+01,0.4825e+01,
7218  *0.5358e+01,0.5947e+01,0.6597e+01,0.7314e+01,0.8106e+01,0.8978e+01,
7219  *0.9939e+01,0.1099e+02,0.1211e+02,0.1319e+02,0.1367e+02/
7220  DATA ((phr(i,j),j=1,83),i=06,06) /
7221  *0.3540e+00,0.3501e+00,0.3360e+00,0.3166e+00,0.2969e+00,0.2801e+00,
7222  *0.2677e+00,0.2594e+00,0.2541e+00,0.2500e+00,0.2461e+00,0.2417e+00,
7223  *0.2369e+00,0.2317e+00,0.2263e+00,0.2211e+00,0.2160e+00,0.2113e+00,
7224  *0.2070e+00,0.2033e+00,0.2001e+00,0.1976e+00,0.1956e+00,0.1943e+00,
7225  *0.1937e+00,0.1937e+00,0.1945e+00,0.1960e+00,0.1982e+00,0.2013e+00,
7226  *0.2053e+00,0.2102e+00,0.2162e+00,0.2232e+00,0.2313e+00,0.2408e+00,
7227  *0.2516e+00,0.2639e+00,0.2779e+00,0.2937e+00,0.3115e+00,0.3213e+00,
7228  *0.3315e+00,0.3540e+00,0.3791e+00,0.4073e+00,0.4387e+00,0.4739e+00,
7229  *0.5131e+00,0.5569e+00,0.6057e+00,0.6603e+00,0.7211e+00,0.7890e+00,
7230  *0.8647e+00,0.9493e+00,0.1044e+01,0.1149e+01,0.1267e+01,0.1398e+01,
7231  *0.1545e+01,0.1708e+01,0.1891e+01,0.2095e+01,0.2322e+01,0.2575e+01,
7232  *0.2856e+01,0.3169e+01,0.3517e+01,0.3902e+01,0.4328e+01,0.4799e+01,
7233  *0.5318e+01,0.5890e+01,0.6519e+01,0.7208e+01,0.7963e+01,0.8788e+01,
7234  *0.9685e+01,0.1065e+02,0.1166e+02,0.1261e+02,0.1301e+02/
7235  DATA ((phr(i,j),j=1,83),i=07,07) /
7236  *0.3121e+00,0.3097e+00,0.3008e+00,0.2882e+00,0.2753e+00,0.2643e+00,
7237  *0.2562e+00,0.2509e+00,0.2473e+00,0.2445e+00,0.2417e+00,0.2384e+00,
7238  *0.2348e+00,0.2307e+00,0.2265e+00,0.2223e+00,0.2182e+00,0.2144e+00,
7239  *0.2109e+00,0.2078e+00,0.2052e+00,0.2030e+00,0.2014e+00,0.2004e+00,
7240  *0.2000e+00,0.2002e+00,0.2011e+00,0.2027e+00,0.2051e+00,0.2082e+00,
7241  *0.2123e+00,0.2173e+00,0.2232e+00,0.2303e+00,0.2386e+00,0.2482e+00,
7242  *0.2591e+00,0.2717e+00,0.2859e+00,0.3019e+00,0.3201e+00,0.3300e+00,
7243  *0.3404e+00,0.3633e+00,0.3889e+00,0.4176e+00,0.4496e+00,0.4854e+00,
7244  *0.5253e+00,0.5699e+00,0.6196e+00,0.6749e+00,0.7367e+00,0.8055e+00,
7245  *0.8822e+00,0.9677e+00,0.1063e+01,0.1169e+01,0.1288e+01,0.1419e+01,
7246  *0.1566e+01,0.1730e+01,0.1912e+01,0.2115e+01,0.2341e+01,0.2591e+01,
7247  *0.2869e+01,0.3177e+01,0.3518e+01,0.3895e+01,0.4309e+01,0.4765e+01,
7248  *0.5265e+01,0.5811e+01,0.6405e+01,0.7049e+01,0.7744e+01,0.8489e+01,
7249  *0.9280e+01,0.1010e+02,0.1093e+02,0.1165e+02,0.1192e+02/
7250  DATA ((phr(i,j),j=1,83),i=08,08) /
7251  *0.3070e+00,0.3061e+00,0.3027e+00,0.2975e+00,0.2918e+00,0.2865e+00,
7252  *0.2821e+00,0.2787e+00,0.2760e+00,0.2735e+00,0.2711e+00,0.2684e+00,
7253  *0.2656e+00,0.2626e+00,0.2594e+00,0.2562e+00,0.2530e+00,0.2500e+00,
7254  *0.2471e+00,0.2446e+00,0.2423e+00,0.2404e+00,0.2390e+00,0.2380e+00,
7255  *0.2375e+00,0.2377e+00,0.2385e+00,0.2400e+00,0.2422e+00,0.2453e+00,
7256  *0.2493e+00,0.2543e+00,0.2604e+00,0.2677e+00,0.2762e+00,0.2861e+00,
7257  *0.2976e+00,0.3108e+00,0.3258e+00,0.3428e+00,0.3620e+00,0.3725e+00,
7258  *0.3836e+00,0.4079e+00,0.4351e+00,0.4655e+00,0.4993e+00,0.5371e+00,
7259  *0.5791e+00,0.6258e+00,0.6776e+00,0.7351e+00,0.7988e+00,0.8694e+00,
7260  *0.9476e+00,0.1034e+01,0.1130e+01,0.1236e+01,0.1353e+01,0.1482e+01,
7261  *0.1625e+01,0.1783e+01,0.1957e+01,0.2148e+01,0.2359e+01,0.2590e+01,
7262  *0.2844e+01,0.3121e+01,0.3424e+01,0.3754e+01,0.4112e+01,0.4498e+01,
7263  *0.4913e+01,0.5356e+01,0.5826e+01,0.6320e+01,0.6833e+01,0.7358e+01,
7264  *0.7884e+01,0.8390e+01,0.8846e+01,0.9187e+01,0.9295e+01/
7265  DATA ((phr(i,j),j=1,83),i=09,09) /
7266  *0.3321e+00,0.3315e+00,0.3294e+00,0.3266e+00,0.3238e+00,0.3214e+00,
7267  *0.3192e+00,0.3169e+00,0.3142e+00,0.3111e+00,0.3075e+00,0.3036e+00,
7268  *0.2994e+00,0.2950e+00,0.2905e+00,0.2860e+00,0.2817e+00,0.2775e+00,
7269  *0.2735e+00,0.2698e+00,0.2665e+00,0.2635e+00,0.2609e+00,0.2587e+00,
7270  *0.2571e+00,0.2561e+00,0.2556e+00,0.2558e+00,0.2568e+00,0.2586e+00,
7271  *0.2613e+00,0.2650e+00,0.2697e+00,0.2756e+00,0.2827e+00,0.2913e+00,
7272  *0.3013e+00,0.3131e+00,0.3267e+00,0.3422e+00,0.3600e+00,0.3698e+00,
7273  *0.3802e+00,0.4030e+00,0.4287e+00,0.4575e+00,0.4899e+00,0.5261e+00,
7274  *0.5665e+00,0.6115e+00,0.6617e+00,0.7175e+00,0.7795e+00,0.8484e+00,
7275  *0.9248e+00,0.1010e+01,0.1103e+01,0.1208e+01,0.1323e+01,0.1451e+01,
7276  *0.1592e+01,0.1749e+01,0.1922e+01,0.2113e+01,0.2324e+01,0.2557e+01,
7277  *0.2813e+01,0.3095e+01,0.3403e+01,0.3740e+01,0.4106e+01,0.4502e+01,
7278  *0.4928e+01,0.5383e+01,0.5863e+01,0.6364e+01,0.6878e+01,0.7395e+01,
7279  *0.7898e+01,0.8366e+01,0.8764e+01,0.9041e+01,0.9119e+01/
7280  DATA ((phr(i,j),j=1,83),i=10,10) /
7281  *0.4248e+00,0.4242e+00,0.4221e+00,0.4189e+00,0.4153e+00,0.4116e+00,
7282  *0.4081e+00,0.4045e+00,0.4006e+00,0.3964e+00,0.3918e+00,0.3869e+00,
7283  *0.3818e+00,0.3764e+00,0.3709e+00,0.3654e+00,0.3600e+00,0.3547e+00,
7284  *0.3495e+00,0.3446e+00,0.3401e+00,0.3359e+00,0.3321e+00,0.3288e+00,
7285  *0.3260e+00,0.3239e+00,0.3224e+00,0.3218e+00,0.3219e+00,0.3230e+00,
7286  *0.3251e+00,0.3282e+00,0.3326e+00,0.3383e+00,0.3455e+00,0.3542e+00,
7287  *0.3646e+00,0.3768e+00,0.3911e+00,0.4075e+00,0.4263e+00,0.4366e+00,
7288  *0.4476e+00,0.4717e+00,0.4989e+00,0.5293e+00,0.5633e+00,0.6011e+00,
7289  *0.6431e+00,0.6896e+00,0.7410e+00,0.7977e+00,0.8603e+00,0.9291e+00,
7290  *0.1005e+01,0.1088e+01,0.1179e+01,0.1278e+01,0.1387e+01,0.1506e+01,
7291  *0.1636e+01,0.1778e+01,0.1933e+01,0.2100e+01,0.2283e+01,0.2480e+01,
7292  *0.2693e+01,0.2923e+01,0.3169e+01,0.3433e+01,0.3713e+01,0.4009e+01,
7293  *0.4319e+01,0.4642e+01,0.4973e+01,0.5308e+01,0.5640e+01,0.5962e+01,
7294  *0.6262e+01,0.6528e+01,0.6740e+01,0.6876e+01,0.6911e+01/
7295 c
7296  do 1 i=1,10
7297  do 1 j=1,83
7298  ph(i,j)=phr(i,j)
7299  1 continue
7300  return
7301  end
dust
subroutine dust
Definition: 6sm1.f:3800
index
an array had not been initialized Several spelling and grammar corrections were which is read from the appropriate MCF the above metadata values were hard coded A problem calculating the average background DN for SWIR bands when the moon is in the space view port was corrected The new algorithm used to calculate the average background DN for all reflective bands when the moon is in the space view port is now the same as the algorithm employed by the thermal bands For non SWIR changes in the averages are typically less than Also for non SWIR the black body DNs remain a backup in case the SV DNs are not available For SWIR the changes in computed averages were larger because the old which used the black body suffered from contamination by the micron leak As a consequence of the if SV DNs are not available for the SWIR the EV pixels will not be the granule time is used to identify the appropriate tables within the set given for one LUT the first two or last two tables respectively will be used for the interpolation If there is only one LUT in the set of it will be treated as a constant LUT The manner in which Earth View data is checked for saturation was changed Previously the raw Earth View DNs and Space View DNs were checked against the lookup table values contained in the table dn_sat The change made is to check the raw Earth and Space View DNs to be sure they are less than the maximum saturation value and to check the Space View subtracted Earth View dns against a set of values contained in the new lookup table dn_sat_ev The metadata configuration and ASSOCIATEDINSTRUMENTSHORTNAME from the MOD02HKM product The same metatdata with extensions and were removed from the MOD021KM and MOD02OBC products ASSOCIATEDSENSORSHORTNAME was set to MODIS in all products These changes are reflected in new File Specification which users may consult for exact the pow functions were eliminated in Emissive_Cal and Emissive bands replaced by more efficient code Other calculations throughout the code were also made more efficient Aside from a few round off there was no difference to the product The CPU time decreased by about for a day case and for a night case A minor bug in calculating the uncertainty index for emissive bands was corrected The frame index(0-based) was previously being used the frame number(1-based) should have been used. There were only a few minor changes to the uncertainty index(maximum of 1 digit). 3. Some inefficient arrays(Sigma_RVS_norm_sq) were eliminated and some code lines in Preprocess_L1A_Data were moved into Process_OBCEng_Emiss. There were no changes to the product. Required RAM was reduced by 20 MB. Now
interp
void interp(double *ephemPtr, int startLoc, double *inTime, int numCoefs, int numCom, int numSets, int velFlag, double *posvel)
kernel
subroutine kernel(is, mu, rm, xpl, psl, bp)
Definition: 6sm1.f:4700
print_error
subroutine print_error(tex)
Definition: 6sm1.f:6318
odrayl
subroutine odrayl(wl, tray)
Definition: 6sm1.f:5452
gmd92
subroutine gmd92
Definition: 6sm1.f:2183
gmf
subroutine gmf(gf)
Definition: 6sm1.f:2080
s13aaf
subroutine s13aaf
Definition: 6sm1.f:2480
tav
subroutine tav
Definition: 6sm1.f:2540
subwin
subroutine subwin
Definition: 6sm1.f:6882
leaf
subroutine leaf
Definition: 6sm1.f:2399
ssssss
subroutine ssssss
Definition: 6sm1.f:2
midwin
subroutine midwin
Definition: 6sm1.f:4844
enviro
subroutine enviro(difr, difa, r, palt, xmuv, fra, fae, fr)
Definition: 6sm1.f:3964
oda550
subroutine oda550(iaer, v, taer55)
Definition: 6sm1.f:5397
spline
subroutine spline(s, x, y, n, in, t, il, iu, vl, vu, e, u)
Definition: phs.f:1348
midsum
subroutine midsum
Definition: 6sm1.f:4794
f3
float f3(float z)
cubspln
subroutine cubspln(N, XORGN, YORGN, XINT, YINT)
Definition: atrem_app_refl_f90_cubeio.f:3156
sign
#define sign(x)
Definition: misc.h:95
pos_fft
subroutine pos_fft(j, tu, xlon, xlat, asol, phi0)
Definition: 6sm1.f:6082
real
#define real
Definition: DbAlgOcean.cpp:26
trunca
subroutine trunca(coeff)
Definition: 6sm1.f:6983
splin2
subroutine splin2(x1a, x2a, ya, y2a, m, n, x1, x2, y)
Definition: 6sm1.f:6680
subsum
subroutine subsum
Definition: 6sm1.f:6832
fac
#define fac
Definition: atmocor1_land.c:111
wate
subroutine wate
Definition: 6sm1.f:7138
specinterp
subroutine specinterp(wl, taer55, taer55p, tamoy, tamoyp, pizmoy, pizmoyp)
Definition: 6sm1.f:6625
parameter
README for MOD_PR03(V6.1.0) 2. POINTS OF CONTACT it can be either SDP Toolkit or MODIS Packet for Terra input files The orbit validation configuration parameter(LUN 600281) must be either "TRUE" or "FALSE". It needs to be "FALSE" when running in Near Real Time mode
possol
subroutine possol(month, jday, tu, xlon, xlat, asol, phi0)
Definition: 6sm1.f:6047
us62
subroutine us62
Definition: 6sm1.f:7062
os
subroutine os(tamoy, trmoy, pizmoy, tamoyp, trmoyp, palt, phirad, nt, mu, np, rm, gb, rp, xl)
Definition: 6sm1.f:5484
atmref
subroutine atmref(iaer, tamoy, trmoy, pizmoy, tamoyp, trmoyp, palt, phi, xmus, xmuv, phirad, nt, mu, np, rm, gb, rp, rorayl, roaero, romix, xlm1, xlm2)
Definition: 6sm1.f:3219
splie2
subroutine splie2(x2a, ya, m, n, y2a)
Definition: 6sm1.f:6664
msrm
subroutine msrm
Definition: 6sm1.f:1618
akd
subroutine akd
Definition: 6sm1.f:1683
glak
subroutine glak(glth, th)
Definition: 6sm1.f:2039
stm
subroutine stm
Definition: 6sm1.f:6698
soilspec
subroutine soilspec
Definition: 6sm1.f:2161
aeroso
subroutine aeroso(iaer, co, xmud, wldis, FILE)
Definition: 6sm1.f:1350
filter
void filter(fctlstr *fctl, l1qstr *l1que, l1str *l1rec, int32_t dscan)
Definition: filter.c:1396
soil
subroutine soil
Definition: 6sm1.f:2116
day_number
subroutine day_number(jday, month, ia, j)
Definition: 6sm1.f:6066
akbrdf
subroutine akbrdf(eei, thmi, uli, sli, rsl1i, wlmoy, rnci, cabi, cwi, vaii, mu, np, rm, rp, brdfint)
Definition: 6sm1.f:2995
power
subroutine power(A, B, R1, R2)
Definition: tmd.lp.f:1380
pressure
subroutine pressure(uw, uo3, xps)
Definition: 6sm1.f:6248
iso
subroutine iso(tamoy, trmoy, pizmoy, tamoyp, trmoyp, palt, nt, mu, rm, gb, xf)
Definition: 6sm1.f:4274
dakg
subroutine dakg(u, a, nq)
Definition: 6sm1.f:2792
csalbr
subroutine csalbr(xtau, xalb)
Definition: 6sm1.f:3618
discom
subroutine discom(idatmp, iaer, xmus, xmuv, phi, taer55, taer55p, palt, phirad, nt, mu, np, rm, gb, rp, ftray, xlm1, xlm2)
Definition: 6sm1.f:3648
difr92
subroutine difr92
Definition: 6sm1.f:1966
fintexp1
real function fintexp1(xtau)
Definition: 6sm1.f:3630
bdm
subroutine bdm
Definition: 6sm1.f:3414
equivwl
subroutine equivwl(iinf, isup, step, wlmoy)
Definition: 6sm1.f:4034
splint
subroutine splint(xa, ya, y2a, n, x, y)
Definition: atrem_app_refl_f90_cubeio.f:3270
water
subroutine water(twat, pdv, watr, ppod, ht, nm, ndv, tauw)
Definition: afrt_rt1.f:1168
mie
subroutine mie(iaer, wldis, ex, sc, asy)
Definition: 6sm1.f:4894
f
#define f
Definition: l1_czcs_hdf.c:702
biz
subroutine biz
Definition: 6sm1.f:1802
ocea
subroutine ocea
Definition: 6sm1.f:5233
presplane
subroutine presplane(uw, uo3, xpp, ftray)
Definition: 6sm1.f:6150
radius
void radius(double A)
Definition: proj_report.c:132
gauss
subroutine gauss(x1, x2, x, w, n)
Definition: 6sm1.f:4055
soot
subroutine soot
Definition: 6sm1.f:6460
abs
#define abs(a)
Definition: misc.h:90
exscphase
subroutine exscphase(X, nr, ni, Qext, Qsca, p11)
Definition: 6sm1.f:5035
scatra
subroutine scatra(taer, taerp, tray, trayp, piza, palt, nt, mu, rm, gb, xmus, xmuv, ddirtt, ddiftt, udirtt, udiftt, sphalbt, ddirtr, ddiftr, udirtr, udiftr, sphalbr, ddirta, ddifta, udirta, udifta, sphalba)
Definition: 6sm1.f:6331
varsol
subroutine varsol(jday, month, dsol)
Definition: 6sm1.f:7114
chand
subroutine chand(xphi, xmuv, xmus, xtau, xrray)
Definition: 6sm1.f:3548
discre
subroutine discre(ta, ha, tr, hr, it, nt, yy, dd, ppp2, ppp1, zx)
Definition: 6sm1.f:3760
tropic
subroutine tropic
Definition: 6sm1.f:6933
akalbe
subroutine akalbe(albbrdf)
Definition: 6sm1.f:3146
bbm
subroutine bbm
Definition: 6sm1.f:3281


ABOUT

Our Team

Contact Us

DATA

Get Started

Find Data

Use Data

TOOLS

SeaBASS

SeaDAS

Giovanni Data Visualizer

Worldview Mapping Interface

Level 3 Time Series Plotter

Request a SeaHawk Image

Mission Quality Monitor

HELP

Level 1 & 2 Browser Help

Level 3 & 4 Browser Help

File Search Help

Search & Download Help

Earthdata Forum

Join Mailing List

How to Cite Data

CONNECT WITH US
COMPLIANCE

Web Privacy Policy

Data & Information Policy

Communications Policy

Accessibility Policy

Freedom of Information Act

USA.gov

Responsible NASA Official: Sean Bailey
Curator: OceanColor Webmaster