0000001 subroutine comrho(wavlen,rhon) 0000002 c 0000003 c subroutine comrho determins the 'rhon' (molecular depoarization factor) value for 0000004 c for the given wavelength 'wavlen'. A table of rhons and wavelengths computed from 0000005 c King's correction factor (see Bates...Planet. Space Sci. vol 32, 785-790, 1984) 0000006 c are used for this purpose. A linear interpolation method is used for determining 0000007 c rhon 0000008 c 0000009 implicit real*8 (a-h,o-z) 0000010 real*8 rnb(24) 0000011 integer*4 la(24) 0000012 c 0000013 data rnb/0.0454,0.0438,0.0422,0.0411,0.0400,0.0389,0.0378,0.0367, 0000014 1 0.0356,0.0345,0.0339,0.0328,0.0323,0.0317,0.0317,0.0312, 0000015 2 0.0306,0.0306,0.0301,0.0301,0.0301,0.0295,0.0295,0.0295/ 0000016 c 0000017 data la /2000,2050,2100,2150,2200,2250,2300,2400,2500,2600,2700, 0000018 1 2800,2900,3000,3100,3200,3300,3400,3500,3600,3700,3800, 0000019 2 3900,4000/ 0000020 c 0000021 c 0000022 c write(33,222) wavlen 0000023 222 format('comrho wavelength',1pe12.4) 0000024 lam=int(wavlen+0.5) 0000025 do i=1,24 0000026 if(lam .gt. la(i) .and. lam .le. la(i+1)) then 0000027 grad=(rnb(i+1)-rnb(i))/float(la(i+1)-la(i)) 0000028 rhon=rnb(i)+grad*(wavlen-float(la(i))) 0000029 endif 0000030 enddo 0000031 c 0000032 c write(33,100) wavlen,rhon 0000033 100 format('wavelength rhon', 1p2e12.4) 0000034 c return 0000035 end ENTRY POINTS Name Type BlockNo comrho SUBR 3 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References comrho SUBR 1D float INTRINSIC 27 28 int INTRINSIC 24 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References grad R*8 VAR AUTO 3 16 27= 28 i I*4 VAR AUTO 3 8 25= 26(2) 27(4) 28(2) 30= la I*4 (24) VAR DATA 6 0 11D 17I 26(2) 27(2) 28A lam I*4 VAR AUTO 3 4 24= 26(2) rhon R*8 VAR ARG 1D 28= rnb R*8 (24) VAR DATA 5 0 10D 13I 27(2) 28 wavlen R*8 VAR ARG 1D 24 28 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 33 222 23 0000036 subroutine ctol(lwav) 0000037 c --author: c seftor 0000038 c --date: 28-feb-91 0000039 c --purpose: convert character string to integer 0000040 c --and set values of logical array 0000041 logical lwav(12) 0000042 integer iwav, isza 0000043 include "inchr.inc" 0000044 c 0000045 if (wavnum(2:2) .eq. '-') then 0000046 read (wavnum(1:1),'(i2)') istrt 0000047 if (wavnum(4:4) .eq. ' ') then 0000048 read (wavnum(3:3),'(i2)') iend 0000049 else 0000050 read (wavnum(3:4),'(i2)') iend 0000051 endif 0000052 do 550 i = istrt,iend 0000053 lwav(i) = .true. 0000054 550 continue 0000055 else if (wavnum(3:3).eq.'-') then 0000056 read (wavnum(1:2),'(i2)') istrt 0000057 read (wavnum(4:5),'(i2)') iend 0000058 do 575 i = istrt,iend 0000059 lwav(i) = .true. 0000060 575 continue 0000061 else 0000062 j = 1 0000063 do 600 i = 2,21 0000064 if (wavnum(i:i) .eq. ',') then 0000065 read (wavnum(j:i-1),'(i2)') iwav 0000066 j = i + 1 0000067 lwav(iwav) = .true. 0000068 if (wavnum(j:j) .eq. ' ') goto 700 0000069 else if (wavnum(i:i) .eq. ' ') then 0000070 read (wavnum(j:i-1),'(i2)') iwav 0000071 lwav(iwav) = .true. 0000072 goto 700 0000073 endif 0000074 600 continue 0000075 700 continue 0000076 endif 0000077 return 0000078 end INCLUDE FILES FileNo File name 1 inchr.inc ENTRY POINTS Name Type BlockNo ctol SUBR 9 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References ctol SUBR 36D COMMON BLOCKS Name Size BlockNo inchr_ 35 11 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References i I*4 VAR AUTO 9 12 52= 53 54= 58= 59 60= 63= 64(3) 65 66 69(3) 70 74= iend I*4 VAR AUTO 9 8 48= 50= 52 57= 58 istrt I*4 VAR AUTO 9 4 46= 52 56= 58 isza I*4 VAR 42D Variable declared and not used iwav I*4 VAR AUTO 9 72 42D 65= 67 70= 71 j I*4 VAR AUTO 9 20 62= 65(2) 66= 68(3) 70(2) lwav L*4 (12) VAR ARG 36D 41D 53= 59= 67= 71= prfnam CH*8 VAR COMMON 11 0 1-2D 1-4D wavnum CH*27 VAR COMMON 11 8 1-3D 1-4D 45 46A 47 48A 50A 55 56A 57A 64 65A 68 69 70A LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 550 54 575 60 600 74 700 75 0000079 function dexpi(x) 0000080 c*********************************************************************** 0000081 c this subroutine calculates the exponential integral quantities. 0000082 c the exponential integrals are calculates in double precision, 0000083 c and then truncated to single precision values. 0000084 c computations of exponential integral with fifteen significant 0000085 c figure accuracy. 0000086 c 0000087 c for negative values of the argument 0000088 c range 1 greater than -1.0d-20. gamma + log( qabs of x ) 0000089 c range 2 -1.d-20 to -1.5, 3 point gaussian quadrature. 0000090 c range 3 -1.5 to -4.65, ratio of 2 polynomials each with 7 terms. 0000091 c range 4 -4.65 to -12.0, ratio of 2 polynomials each with 6 terms. 0000092 c range 5 -12.0 to -170.0, 12 point gauss-laguerre quadrature. 0000093 c 0000094 c for positive values of the argument 0000095 c range 1 less than 1.0d-20, gamma + log(x) 0000096 c range 2 1.0d-20 to 40.0, 12 point gaussian quadrature. 0000097 c range 3 40.0 to 173.0, 12 point gauss-laguerre quadrature. 0000098 c 0000099 c 0000100 c*********************************************************************** 0000101 implicit integer*4(i-n),real*8 (a-h,o-z) 0000102 real * 8 a1(3),b1(3),a2(7),b2(7),a3(6),b3(6),a4(12),b4(12), 0000103 1 a5(12),b5(12) 0000104 data a1 / 0.1193095930415965d+0, 0.3306046932331323d+0, 0000105 1 0.4662347571015760d+0/ 0000106 data b1 / 0.4679139345726910d+0, 0.3607615730461336d+0, 0000107 1 0.1713244923791703d+0/ 0000108 data a2 / 0000109 1 0.2823912701457739d-1, 0.3052042817823067d+1, 0000110 1 0.2158885931211323d+2, 0.4104611319636983d+2, 0000111 2 0.2785527592726121d+2, 0.7133086969436196d+1, 0000112 3 0.5758931590224375d+0/ 0000113 data b2 / 0000114 1 0.1000000000000000d+1, 0.1383869728490638d+2, 0000115 1 0.4880858183073600d+2, 0.6348804630786363d+2, 0000116 2 0.3441289899236299d+2, 0.7708964199043784d+1, 0000117 3 0.5758934565014882d+0/ 0000118 data a3 / 0000119 1 0.7630772325814641d-1, 0.2123699219410890d+1, 0000120 1 0.4745350785776186d+1, 0.2966421696379266d+1, 0000121 2 0.6444800036068992d+0, 0.4295808082119383d-1/ 0000122 data b3 / 0000123 1 0.1000000000000000d+1, 0.5278950049492932d+1, 0000124 1 0.7196111390658517d+1, 0.3567945294128107d+1, 0000125 2 0.6874380519301884d+0, 0.4295808112146861d-1/ 0000126 data a4 / 0000127 1 0.1157221173580207d+0, 0.6117574845151307d+0, 0000128 1 0.1512610269776419d+1, 0.2833751337743507d+1, 0000129 2 0.4599227639418348d+1, 0.6844525453115177d+1, 0000130 3 0.9621316842456867d+1, 0.1300605499330635d+2, 0000131 4 0.1711685518746226d+2, 0.2215109037939701d+2, 0000132 5 0.2848796725098400d+2, 0.3709912104446692d+2/ 0000133 data b4 / 0000134 1 0.2647313710554432d+0, 0.3777592758731380d+0, 0000135 1 0.2440820113198776d+0, 0.9044922221168093d-1, 0000136 2 0.2010238115463410d-1, 0.2663973541865316d-2, 0000137 3 0.2032315926629994d-3, 0.8365055856819799d-5, 0000138 4 0.1668493876540910d-6, 0.1342391030515004d-8, 0000139 5 0.3061601635035021d-11, 0.8148077467426242d-15/ 0000140 data a5 / 0000141 1 0.3202844643130281d-1, 0.9555943373680816d-1, 0000142 1 0.1575213398480817d+0, 0.2168967538130226d+0, 0000143 2 0.2727107356944198d+0, 0.3240468259684878d+0, 0000144 3 0.3700620957892772d+0, 0.4100009929869515d+0, 0000145 4 0.4432077635022005d+0, 0.4691372760013664d+0, 0000146 5 0.4873642779856547d+0, 0.4975936099985107d+0/ 0000147 data b5 / 0000148 1 0.1279381953467522d+0, 0.1258374563468283d+0, 0000149 1 0.1216704729278034d+0, 0.1155056680537256d+0, 0000150 2 0.1074442701159656d+0, 0.9761865210411389d-1, 0000151 3 0.8619016153195328d-1, 0.7334648141108031d-1, 0000152 4 0.5929858491543678d-1, 0.4427743881741981d-1, 0000153 5 0.2853138862893366d-1, 0.1234122979998720d-1/ 0000154 10 format(10x,'the argument of expi is very close to zero. it is', 0000155 1e25.16//) 0000156 20 format(10x,'the argument of expi is very large. it is',e25.16//) 0000157 c 0000158 c 0000159 dexpi = 0.0d+00 0000160 if (x) 200,100,300 0000161 c 100 write (6,10) x 0000162 100 continue 0000163 return 0000164 200 ax = dabs(x) 0000165 if ( x .gt. -1.0d-20 ) go to 201 0000166 if ( x .gt. -1.5 ) go to 205 0000167 if ( x .gt. -4.65 ) go to 215 0000168 if ( x .gt. -12.0 ) go to 225 0000169 if ( x .gt. -170.0 ) go to 235 0000170 return 0000171 201 dexpi = dlog(ax) +0.57721566490153d+00 0000172 return 0000173 205 yy = dexp(-0.5 * ax) 0000174 yz = dexp(a1(1)*ax) 0000175 sumn=(1.0 -yy/yz)/(0.5 +a1(1))+(1.0 -yy*yz)/(0.5 -a1(1)) 0000176 yz = dexp(a1(2)*ax) 0000177 sumd=(1.0 -yy/yz)/(0.5 +a1(2))+(1.0 -yy*yz)/(0.5 -a1(2)) 0000178 yz = dexp(a1(3)*ax) 0000179 sumt=(1.0 -yy/yz)/(0.5 +a1(3))+(1.0 -yy*yz)/(0.5 -a1(3)) 0000180 dexpi= -0.5 *(b1(1)*sumn+b1(2)*sumd+b1(3)*sumt) 0000181 dexpi = dexpi + dlog(ax) + 0.57721566490153d+00 0000182 return 0000183 215 sumn =(((((a2(7)*ax+a2(6))*ax+a2(5))*ax+a2(4))*ax+a2(3))*ax+a2(2)) 0000184 1*ax+a2(1) 0000185 sumd =(((((b2(7)*ax+b2(6))*ax+b2(5))*ax+b2(4))*ax+b2(3))*ax+b2(2)) 0000186 1*ax+b2(1) 0000187 218 dexpi= sumn/(sumd*x) 0000188 dexpi = dexpi * dexp(x) 0000189 return 0000190 225 sumn=((((a3(6)*ax+a3(5))*ax+a3(4))*ax+a3(3))*ax+a3(2))*ax+a3(1) 0000191 sumd=((((b3(6)*ax+b3(5))*ax+b3(4))*ax+b3(3))*ax+b3(2))*ax+b3(1) 0000192 go to 218 0000193 235 do 238 j = 1,12 0000194 238 dexpi=dexpi + b4(j)/(1.0 + a4(j)/ax) 0000195 dexpi = (dexp(x)/ax)*(-dexpi) 0000196 return 0000197 300 if ( x .le. 1.0d-20 ) go to 301 0000198 if ( x .le. 40.0 ) go to 305 0000199 if ( x .le. 173.0 ) go to 335 0000200 c write (6,20 ) x 0000201 return 0000202 301 dexpi= dlog(x) + 0.57721566490153d+00 0000203 return 0000204 305 yy = dexp( 0.5 * x) 0000205 do 310 j = 1,12 0000206 yz = dexp(-a5(j)* x ) 0000207 dexpi =(( 1.0 - yy/yz)/(0.5 + a5(j)) + ( 1.0 - yy*yz)/ 0000208 1 ( 0.5 - a5(j)) )*b5(j) + dexpi 0000209 310 continue 0000210 dexpi = -0.5 * dexpi + dlog(x) + 0.57721566490153d+00 0000211 return 0000212 335 do 338 j = 1,12 0000213 338 dexpi = dexpi + b4(j)/(1.0-a4(j)/x) 0000214 dexpi = (dexp(x)/x) * dexpi 0000215 return 0000216 end ENTRY POINTS Name Type BlockNo dexpi R*8 33 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dabs INTRINSIC 164 dexp INTRINSIC 173 174 176 178 188 195 204 206 214 dexpi R*8 79D 159= 171= 180= 181(2)= 187= 188(2)= 194(2)= 195(2)= 202= 207(2)= 210(2)= 213(2)= 214(2)= dlog INTRINSIC 171 181 202 210 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a1 R*8 (3) VAR DATA 36 0 102D 104I 174 175(2) 176 177(2) 178 179(2) a2 R*8 (7) VAR DATA 38 0 102D 108I 183(7) a3 R*8 (6) VAR DATA 40 0 102D 118I 190(6) a4 R*8 (12) VAR DATA 42 0 102D 126I 194 213 a5 R*8 (12) VAR DATA 44 0 102D 140I 206 207(2) ax R*8 VAR AUTO 33 16 164= 171A 173 174 176 178 181A 183(6) 185(6) 190(5) 191(5) 194 195 b1 R*8 (3) VAR DATA 37 0 102D 106I 180(3) b2 R*8 (7) VAR DATA 39 0 102D 113I 185(7) b3 R*8 (6) VAR DATA 41 0 102D 122I 191(6) b4 R*8 (12) VAR DATA 43 0 102D 133I 194 213 b5 R*8 (12) VAR DATA 45 0 102D 147I 207 j I*4 VAR AUTO 33 68 193= 194(3)= 205= 206 207(3) 209= 212= 213(3)= sumd R*8 VAR AUTO 33 56 177= 180 185= 187 191= sumn R*8 VAR AUTO 33 48 175= 180 183= 187 190= sumt R*8 VAR AUTO 33 64 179= 180 x R*8 VAR ARG 79D 160 164A 165 166 167 168 169 187 188A 195A 197 198 199 202A 204 206 210A 213 214(2)A yy R*8 VAR AUTO 33 32 173= 175(2) 177(2) 179(2) 204= 207(2) yz R*8 VAR AUTO 33 40 174= 175(2) 176= 177(2) 178= 179(2) 206= 207(2) LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 154 200 164 215 183 235 193 301 202 335 212 20 156 201 171 218 187 238 194 305 204 338 213 100 162 205 173 225 190 300 197 310 209 0000217 subroutine dexpk(a,b) 0000218 c 0000219 c*********************************************************************** 0000220 c 0000221 cccc 0000222 c subroutine dexpk 0000223 c 0000224 c purpose- 0000225 c 0000226 c calculate exponential integrals of orders 1 to 6 and the 0000227 c elements of k1 matrix (dave's eqn. 4-11) 0000228 c 0000229 c method- 0000230 c recursion relation for the exponential integrals is used 0000231 c see handbook of math functions-abramowitz and stegun (p229) 0000232 c 0000233 c calling sequence- call dexpk(a,b) 0000234 c 0000235 c variables type i/o description 0000236 c --------- ---- --- ----------- 0000237 c a r*8 i abs(a-b) is the argument of the 0000238 c b r*8 i exponential integrals 0000239 c 0000240 c result of the subroutine is returned in common block 'es' 0000241 c e(6) r*8 o exponential integrals 0000242 c eek(6) r*8 o elements of the k-matrix 0000243 c 0000244 c external references - dexpi 0000245 c 0000246 c modifications- by k.klenk 8/19/77 0000247 c 0000248 c functions k1(1) and k1(2) are also calculated and are returned 0000249 c in eek(4) and eek(5) respectively (dave's eqn. 4.7) 0000250 c 0000251 c last modified 9/4/93....zia ahmad 0000252 c purpose: to account for molecular depolarization 0000253 c 0000254 c last modified 03/14/95...dave flittner 0000255 c purpose: set pressure scale height used in gravity correction 0000256 c to rayleigh scattering od. Create new variable pscaleforg and 0000257 c pass in common block consts. 0000258 cccc 0000259 c*********************************************************************** 0000260 c 0000261 implicit real *8 (a-h,o-z) 0000262 real *8 dexpi,dt,dum,dtemp,de(6) 0000263 include "consts.inc" 0000264 include "es.inc" 0000265 c 0000266 c new statement 9/4/93 0000267 include "depolt.inc" 0000268 c end of new statement 0000269 0000270 c 0000271 c*****calculate exponential integrals 0000272 c 0000273 dt = dabs(a-b) 0000274 de(1) = - dexpi(-dt) 0000275 dum = dexp(-dt) 0000276 do 70 j = 2, 6 0000277 70 de(j) = odan(j)*(dum-dt*de(j-1)) 0000278 do 80 i=1,6 0000279 80 e(i) = de(i) 0000280 c 0000281 c*****calculate the k matrix and functions k1(1) and k(2) 0000282 c new statements added here 9/4/93 0000283 if(ipol .eq. 0)then 0000284 eek(1) = 0.375*(e(1) + e(5)) 0000285 eek(2) = c38sq2 * (de(3) - de(5)) 0000286 eek(3) = 0.75 * (de(1)-2.d+00 * de(3) + de(5)) 0000287 eek(4)=0.375*(e(1)+e(3)-2.0*e(5)) 0000288 eek(5)=0.1875*(e(1)+2.0*e(3)+e(5)) 0000289 else 0000290 eek(1)=q12s*((sdp**2+q**2)*e(1)+2.0d0*q*e(3)+e(5)) 0000291 eek(2)=q12s*delp*(q*(e(1)-e(3))+e(3)-e(5)) 0000292 eek(3)=q12s*delp**2*(e(1)-2.0d0*e(3)+e(5)) 0000293 eek(4)=0.375d0*q2*(e(1)+e(3)-2.0d0*e(5)) 0000294 eek(5)=0.1875d0*q2*(e(1)+2.0d0*e(3)+e(5)) 0000295 endif 0000296 return 0000297 end INCLUDE FILES FileNo File name 1 consts.inc 2 es.inc 3 depolt.inc ENTRY POINTS Name Type BlockNo dexpk SUBR 64 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dabs INTRINSIC 273 dexp INTRINSIC 275 dexpi R*8 EXTERNAL 262D 274 dexpk SUBR 217D COMMON BLOCKS Name Size BlockNo consts_ 112 66 depolt_ 68 70 es_ 144 68 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 VAR ARG 217D 273 b R*8 VAR ARG 217D 273 c1415 R*8 VAR COMMON 66 72 1-2D 1-4D c215 R*8 VAR COMMON 66 48 1-2D 1-4D c2815 R*8 VAR COMMON 66 80 1-2D 1-4D c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D 285 c815 R*8 VAR COMMON 66 56 1-2D 1-4D cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D cons R*8 VAR COMMON 66 32 1-2D 1-4D de R*8 (6) VAR AUTO 64 56 262D 274= 277(2)= 279 285(2) 286(3) delp R*8 VAR COMMON 70 40 3-3D 3-4D 291 292 dt R*8 VAR AUTO 64 8 262D 273= 274 275 277 dtemp R*8 VAR 262D Variable declared and not used dum R*8 VAR AUTO 64 80 262D 275= 277 e R*8 (6) VAR COMMON 68 48 2-2D 2-3D 279= 284(2) 287(3) 288(3) 290(3) 291(4) 292(3) 293(3) 294(3) eek R*8 (6) VAR COMMON 68 96 2-2D 2-3D 284= 285= 286= 287= 288= 290= 291= 292= 293= 294= gama R*8 VAR COMMON 70 8 3-3D 3-4D i I*4 VAR AUTO 64 88 278= 279(3)= ipol I*4 VAR COMMON 70 64 3-2D 3-4D 283 j I*4 VAR AUTO 64 84 276= 277(4)= kskip R*8 VAR COMMON 66 104 1-2D 1-4D numek R*8 VAR COMMON 66 96 1-2D 1-4D odan R*8 (6) VAR COMMON 68 0 2-2D 2-3D 277 pi R*8 VAR COMMON 66 0 1-2D 1-4D pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D q R*8 VAR COMMON 70 16 3-3D 3-4D 290(2) 291 q1 R*8 VAR COMMON 70 24 3-3D 3-4D q12s R*8 VAR COMMON 70 56 3-3D 3-4D 290 291 292 q2 R*8 VAR COMMON 70 32 3-3D 3-4D 293 294 r R*8 VAR COMMON 66 16 1-2D 1-4D rhon R*8 VAR COMMON 70 0 3-3D 3-4D rinv R*8 VAR COMMON 66 24 1-2D 1-4D sdp R*8 VAR COMMON 70 48 3-3D 3-4D 290 sq2 R*8 VAR COMMON 66 40 1-2D 1-4D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 70 277 80 279 0000298 subroutine dexpk1(a,b) 0000299 c 0000300 c*********************************************************************** 0000301 c 0000302 cccc 0000303 c subroutine dexpk1 0000304 c 0000305 c purpose- 0000306 c calculate the elements of k1 matrix averaged over the interval 0000307 c a-b . (dave's eq. 4.11) 0000308 c 0000309 c method- 0000310 c the averages are calculated using eq(5.1.26) in abramowitz and 0000311 c segun. 0000312 c 0000313 c calling sequence - call dexpk1(a,b) 0000314 c 0000315 c 0000316 c variables type i/o description 0000317 c --------- ---- --- ----------- 0000318 c a r*8 i abs(a-b) is the argument of the 0000319 c b r*8 i exponential integrals 0000320 c 0000321 c result of the subroutine is returned in common block 'es' 0000322 c e(6) r*8 o exponential integrals 0000323 c eek(6) r*8 o elements of the k-matrix 0000324 c 0000325 c external references - dexpi 0000326 c 0000327 c modifications- by k.klenk 8/19/77 0000328 c 0000329 c functions k1(1) and k1(2) are also calculated and are returned 0000330 c in eek(4) and eek(5) respectively (dave's eqn. 4.7) 0000331 c 0000332 c last modified by zia ahmad 9/10/93 0000333 c purpose: to include the effect of molecular anisotropy 0000334 c 0000335 c last modified 03/14/95...dave flittner 0000336 c purpose: set pressure scale height used in gravity correction 0000337 c to rayleigh scattering od. Create new variable pscaleforg and 0000338 c pass in common block consts. 0000339 c 0000340 c*********************************************************************** 0000341 c 0000342 cccc 0000343 c 0000344 implicit integer*4(i-n),real*8 (a-h,o-z) 0000345 real *8 de(6) 0000346 include "consts.inc" 0000347 include "es.inc" 0000348 c 0000349 c new statemnet 0000350 include "depolt.inc" 0000351 c end of new statement 0000352 c 0000353 c 0000354 c*****same as dexpk- calculate expon. integrals 0000355 c 0000356 dt = dabs(a-b) 0000357 de(1) = - dexpi(-dt) 0000358 dum = dexp(-dt) 0000359 do 70 j = 2, 6 0000360 70 de(j) = odan(j)*(dum-dt*de(j-1)) 0000361 do 80 i=1,6 0000362 80 e(i) = de(i) 0000363 c 0000364 c*****calculate elements of k1 matrix (azimuth independent term) 0000365 c by averaging over dt 0000366 c also calculate k1(1) and k1(2) functions for azimuth 0000367 c dependent terms 0000368 c new statements added here 0000369 if(ipol.eq.0)then 0000370 eek(1) = 0.375 *(1.2d+00-de(2)-de(6))/dt 0000371 eek(2) = c38sq2*(2.0d+00/15.d+00-de(4)+de(6))/dt 0000372 eek(3)= 0.75d+00*(8.d+00/15.d+00-de(2)+2.d+00*de(4)-de(6))/dt 0000373 eek(4)=(c1415-e(2)-e(4)+2*e(6))*0.375d0/dt 0000374 eek(5)=(c2815-e(2)-2*e(4)-e(6))*0.1875d0/dt 0000375 else 0000376 eek(1)=q12s*((sdp**2+q**2)*(1.0d0-e(2))+ 0000377 1 2.0d0*q*(1.0d0/3.0d0-e(4))+ 0000378 2 (1.0d0/5.0d0-e(6)) )/dt 0000379 eek(2)=q12s*delp*(q*(1.0d0-e(2))+ 0000380 1 (1.0d0-q)*(1.0d0/3.0d0-e(4))- 0000381 2 (1.0d0/5.0d0-e(6)))/dt 0000382 eek(3)=q12s*delp**2*((1.0d0-e(2))- 0000383 1 2.0d0*(1.0d0/3.0d0-e(4))+ 0000384 2 (1.0d0/5.0d0-e(6)))/dt 0000385 eek(4)=q2*0.375d0*(c1415-e(2)-e(4)+2.0d0*e(6))/dt 0000386 eek(5)=q2*0.1875d0*(c2815-e(2)-2.0d0*e(4)-e(6))/dt 0000387 endif 0000388 c end of new statements 0000389 return 0000390 end INCLUDE FILES FileNo File name 1 consts.inc 2 es.inc 3 depolt.inc ENTRY POINTS Name Type BlockNo dexpk1 SUBR 74 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dabs INTRINSIC 356 dexp INTRINSIC 358 dexpi R*8 EXTERNAL 357 dexpk1 SUBR 298D COMMON BLOCKS Name Size BlockNo consts_ 112 66 depolt_ 68 70 es_ 144 68 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 VAR ARG 298D 356 b R*8 VAR ARG 298D 356 c1415 R*8 VAR COMMON 66 72 1-2D 1-4D 373 385 c215 R*8 VAR COMMON 66 48 1-2D 1-4D c2815 R*8 VAR COMMON 66 80 1-2D 1-4D 374 386 c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D 371 c815 R*8 VAR COMMON 66 56 1-2D 1-4D cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D cons R*8 VAR COMMON 66 32 1-2D 1-4D de R*8 (6) VAR AUTO 74 56 345D 357= 360(2)= 362 370(2) 371(2) 372(3) delp R*8 VAR COMMON 70 40 3-3D 3-4D 379 382 dt R*8 VAR AUTO 74 8 356= 357 358 360 370 371 372 373 374 376 379 382 385 386 dum R*8 VAR AUTO 74 80 358= 360 e R*8 (6) VAR COMMON 68 48 2-2D 2-3D 362= 373(3) 374(3) 376(3) 379(3) 382(3) 385(3) 386(3) eek R*8 (6) VAR COMMON 68 96 2-2D 2-3D 370= 371= 372= 373= 374= 376= 379= 382= 385= 386= gama R*8 VAR COMMON 70 8 3-3D 3-4D i I*4 VAR AUTO 74 88 361= 362(3)= ipol I*4 VAR COMMON 70 64 3-2D 3-4D 369 j I*4 VAR AUTO 74 84 359= 360(4)= kskip R*8 VAR COMMON 66 104 1-2D 1-4D numek R*8 VAR COMMON 66 96 1-2D 1-4D odan R*8 (6) VAR COMMON 68 0 2-2D 2-3D 360 pi R*8 VAR COMMON 66 0 1-2D 1-4D pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D q R*8 VAR COMMON 70 16 3-3D 3-4D 376(2) 379(2) q1 R*8 VAR COMMON 70 24 3-3D 3-4D q12s R*8 VAR COMMON 70 56 3-3D 3-4D 376 379 382 q2 R*8 VAR COMMON 70 32 3-3D 3-4D 385 386 r R*8 VAR COMMON 66 16 1-2D 1-4D rhon R*8 VAR COMMON 70 0 3-3D 3-4D rinv R*8 VAR COMMON 66 24 1-2D 1-4D sdp R*8 VAR COMMON 70 48 3-3D 3-4D 376 sq2 R*8 VAR COMMON 66 40 1-2D 1-4D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 70 360 80 362 0000391 subroutine dtaus(cofx,nc,xpt,ncp1) 0000392 c 0000393 c*********************************************************************** 0000394 c 0000395 cccc 0000396 c subroutine dtaus 0000397 c 0000398 c purpose- 0000399 c 1. calculate the avg. optical thickness of each layer and of 0000400 c each half layer at mid points between the layers 0000401 c 2. find the no. of layers between the atmosphere top and a 0000402 c specified bottom (pnot) 0000403 c 0000404 c input/output variables - 0000405 c 0000406 c variables type i/o description 0000407 c --------- ---- --- ----------- 0000408 c formal parameters 0000409 c cofx(4,487) r*8 i spline interpolation coeff. 0000410 c nc i*4 o no. of layers between the top and 0000411 c the bottom(not incl. bottom layer) 0000412 c ncp1 i*4 o nc+1 0000413 c part of common 'thkns' 0000414 c dtsp(202) r*8 o avg. optical thickness of each layer 0000415 c dtts(202) r*8 o avg. optical thickness of each half 0000416 c layer at mid points between layers 0000417 c 0000418 c no external references 0000419 c 0000420 c last modified 03/14/95...dave flittner 0000421 c purpose: set pressure scale height used in gravity correction 0000422 c to rayleigh scattering od. Create new variable pscaleforg and 0000423 c pass in common block consts. Perform gravity correction when 0000424 c computing pnotb. 0000425 c Also use logical switch lgcorrect 0000426 c to impliment the gravity correction to the rayleigh scattering 0000427 c optical depth. 0000428 cccc 0000429 c*********************************************************************** 0000430 c 0000431 implicit integer*4(i-n),real*8 (a-h,o-z) 0000432 real*8 cofx(4,487),xpt 0000433 include "thkns.inc" 0000434 include "contrl.inc" 0000435 include "atmos.inc" 0000436 include "hedout.inc" 0000437 include "consts.inc" 0000438 include "cgcorrect.inc" 0000439 c 0000440 c*****calculate dtsp and dtts and find nc 0000441 c 0000442 c 0000443 0000444 if(lgcorrect)then 0000445 pnotb = pnot * beta * (1.0d0-pscaleforg*dlog(pnot))**2 !def 0000446 else 0000447 pnotb = pnot * beta 0000448 endif 0000449 pnlog = dlog(pnotb) 0000450 dtts(1) = 0.5*tts(2) 0000451 dtsp(1) = dtts(1) 0000452 do 25 i = 2, 202 0000453 dtsp(i) = 0.5*(tts(i+1) - tts(i-1)) 0000454 dtts(i) = 0.5*(tts(i) - tts(i-1)) 0000455 if (tts(i) .lt. pnotb) go to 25 0000456 ncp1 = i 0000457 nc = i - 1 0000458 go to 26 0000459 25 continue 0000460 ncp1 = 202 0000461 nc = 201 0000462 c 0000463 c*****calculate tt and log(tt) of the bottom layer 0000464 c*****(located at pnot)- by spline interpolation 0000465 c 0000466 26 do 35 i = 80, 101 0000467 if (tsl(i) .lt. pnlog) go to 30 0000468 28 k = i - 1 0000469 dum1 = tsl(k+1) - pnlog 0000470 dum2 = pnlog - tsl(k) 0000471 dum3 = dum1*(cofx(1,k)*dum1**2 + cofx(3,k)) + dum2*(cofx(2,k)* 0000472 1dum2**2 + cofx(4,k)) 0000473 ttl(ncp1) = dum3 0000474 tt(ncp1) = dexp(dum3) 0000475 tautot = tt(ncp1) 0000476 tts(ncp1) = pnotb 0000477 go to 40 0000478 30 if (i .eq. 101) go to 28 0000479 35 continue 0000480 c 0000481 c*****correct the dtts and dtsp of the bottom layer 0000482 c 0000483 40 dtts(ncp1) = 0.5*(tts(ncp1) - tts(nc)) 0000484 dtsp(ncp1) = dtts(ncp1) 0000485 dtsp(nc) = dtts(ncp1) + dtts(nc) 0000486 alfaef = (tautot-pnotb)/xpt 0000487 c --store data for archive tape 0000488 rarray(1) = -12.0d0 0000489 rarray(203) = -12.0d0 0000490 do 100 i = 2,ncp1 0000491 j = i+202 0000492 rarray(i) = ttl(i) 0000493 rarray(j)=dlog(tts(i)) 0000494 100 continue 0000495 rarray(405) = code 0000496 rarray(406) = pnot 0000497 rarray(408) = alfaef 0000498 rarray(409) = beta 0000499 do 300 i = 1,82 0000500 psaray(i) = pshold(i) 0000501 300 continue 0000502 do 200 i = 1,imuz 0000503 j = 409 + i 0000504 rarray(j) = thnot(i) 0000505 200 continue 0000506 rarray(824) = wavlen 0000507 iarray(1) = ncp1 0000508 iarray(2) = imuz 0000509 iarray(3) = lambda 0000510 c if (jprint(8).eq.1) 0000511 c 1 write(33,6100)ncp1,pnot,(i,tt(i),tts(i),dtts(i), 0000512 c 2 dtsp(i),i=1,ncp1) 0000513 c6100 format(//,6hincp1=,i3,5x,5hpnot=f5.3/1h0,2(2x,1h1,8x, 0000514 c 1 2htt,12x,3htts,10x,4hdtts,10x,4hdtsp,7x)// 0000515 c 2 (1x,2(i3,4d14.4,4x))) 0000516 return 0000517 end INCLUDE FILES FileNo File name 1 thkns.inc 2 contrl.inc 3 atmos.inc 4 hedout.inc 5 consts.inc 6 cgcorrect.inc ENTRY POINTS Name Type BlockNo dtaus SUBR 81 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dexp INTRINSIC 474 dlog INTRINSIC 445 449 493 dtaus SUBR 391D COMMON BLOCKS Name Size BlockNo atmos_ 48 87 cgcorrect_ 4 92 consts_ 112 66 contrl_ 2808 85 hedout_ 7260 89 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References alb R*8 (11) VAR COMMON 85 200 2-3D 2-5D alfaef R*8 VAR COMMON 85 2792 2-5D 486= 497 alpha0 R*8 VAR COMMON 87 0 3-2D 3-3D azmth R*8 (8) VAR COMMON 85 136 2-3D 2-5D beta R*8 VAR COMMON 87 8 3-2D 3-3D 445 447 498 c1415 R*8 VAR COMMON 66 72 5-2D 5-4D c215 R*8 VAR COMMON 66 48 5-2D 5-4D c2815 R*8 VAR COMMON 66 80 5-2D 5-4D c38sq2 R*8 VAR COMMON 66 64 5-2D 5-4D c815 R*8 VAR COMMON 66 56 5-2D 5-4D cnvrt R*8 VAR COMMON 66 8 5-2D 5-4D code R*8 VAR COMMON 87 16 3-3D 495 cofx R*8 (4,487) VAR ARG 391D 432D 471(4) cons R*8 VAR COMMON 66 32 5-2D 5-4D dtsp R*8 (202) VAR COMMON 83 5656 1-2D 1-3D 451= 453= 484= 485= dtts R*8 (202) VAR COMMON 83 7272 1-2D 1-3D 450= 451 454= 483= 484 485(2) dum1 R*8 VAR AUTO 81 48 469= 471(2) dum2 R*8 VAR AUTO 81 56 470= 471(2) dum3 R*8 VAR AUTO 81 64 471= 473 474A hhold R*8 (101) VAR COMMON 85 1904 2-3D 2-5D i I*4 VAR AUTO 81 36 452= 453(3) 454(3) 455 456 457 459= 466= 467 468 478 479= 490= 491 492(2) 493 494= 499= 500(2) 501= 502= 503 504 505= iarray I*4 (3) VAR COMMON 89 7248 4-2D 4-4D 507= 508= 509= iazmth I*4 VAR COMMON 85 12 2-2D 2-5D imu I*4 VAR COMMON 85 4 2-2D 2-5D imuz I*4 VAR COMMON 85 8 2-2D 2-5D 502 508 j I*4 VAR AUTO 81 80 491= 493 503= 504 k I*4 VAR AUTO 81 40 468= 469 470 471(4) kskip R*8 VAR COMMON 66 104 5-2D 5-4D lambda I*4 VAR COMMON 85 2800 2-2D 2-5D 509 layer I*4 VAR COMMON 85 2804 2-2D 2-5D lgcorrect L*4 VAR COMMON 92 0 6-2D 6-3D 444 nalb I*4 VAR COMMON 85 0 2-2D 2-5D nc I*4 VAR ARG 391D 457= 461= 483 485(2) ncp1 I*4 VAR ARG 391D 456= 460= 473 474 475 476 483(2) 484(2) 485 490 507 numek R*8 VAR COMMON 66 96 5-2D 5-4D pi R*8 VAR COMMON 66 0 5-2D 5-4D pnlog R*8 VAR AUTO 81 32 449= 467 469 470 pnot R*8 VAR COMMON 87 24 3-2D 3-3D 445(2)A 447 496 pnotb R*8 VAR AUTO 81 8 445= 447= 449A 455 476 486 psaray R*8 (82) VAR COMMON 89 6592 4-3D 4-4D 500= pscaleforg R*8 VAR COMMON 66 88 5-2D 5-4D 445 pshold R*8 (101) VAR COMMON 85 1096 2-3D 2-5D 500 r R*8 VAR COMMON 66 16 5-2D 5-4D rarray R*8 (824) VAR COMMON 89 0 4-3D 4-4D 488= 489= 492= 493= 495= 496= 497= 498= 504= 506= rinv R*8 VAR COMMON 66 24 5-2D 5-4D sq2 R*8 VAR COMMON 66 40 5-2D 5-4D tautot R*8 VAR COMMON 87 32 3-2D 3-3D 475= 486 thnot R*8 (10) VAR COMMON 85 2712 2-3D 2-5D 504 thta R*8 (15) VAR COMMON 85 16 2-3D 2-5D tsl R*8 (101) VAR COMMON 83 0 1-2D 1-3D 467 469 470 tt R*8 (202) VAR COMMON 83 808 1-2D 1-3D 474= 475 ttl R*8 (202) VAR COMMON 83 4040 1-2D 1-3D 473= 492 tts R*8 (202) VAR COMMON 83 2424 1-2D 1-3D 450 453(2) 454(2) 455 476= 483(2) 493A wavelen R*8 VAR COMMON 87 40 3-2D 3-3D wavlen R*8 VAR AUTO 81 88 506 x R*8 (101) VAR COMMON 85 288 2-3D 2-5D xpt R*8 VAR ARG 391D 432D 486 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 25 459 28 468 35 479 100 494 300 501 26 466 30 478 40 483 200 505 0000518 0000519 subroutine emmat (imu,imuz,iazmth,thnot,thta,azmth) 0000520 c 0000521 c*********************************************************************** 0000522 c 0000523 cccc 0000524 c subroutine emmat 0000525 c version aug. 1, 1977 0000526 c purpose 0000527 c 0000528 c set up matrix m for each polar backscatter angle 0000529 c and adjoint of m for each solar zenith angle. stores sines 0000530 c and cosines of azimuth and 2*azimuth angles 0000531 c 0000532 c method 0000533 c 0000534 c see dave's paper may 13, 1964 0000535 c 0000536 c calling sequence 0000537 c 0000538 c call emmat (imu,imuz,iazmth,thnot,thta,azmth,ematx, 0000539 c admatx,saz,caz,saz2,caz2,emu,emuz) 0000540 c 0000541 c variable type i/o description 0000542 c -------- ---- --- ----------- 0000543 c 0000544 c imu i*4 i # polar backscatter angles 0000545 c imuz i*4 i # solar zenith angles 0000546 c iazmth i*4 i # azimuth angles 0000547 c thnot(n) r*8 i solar zenith angles (degs) 0000548 c thta(n) r*8 i polar back scatter angles (degs) 0000549 c azmth(n) r*8 i azimuth angles (degs) 0000550 c 0000551 c ematx(3,n) r*8 o m matrix 0000552 c admatx(3,n) r*8 o adjoint matrix 0000553 c saz(m) r*8 o sine of azimuth angle 0000554 c caz(m) r*8 o cosine of azimuth angle 0000555 c saz2(m) r*8 o 2*sine of azimuth angle 0000556 c caz2(m) r*8 o 2*cosine of azimuth angle 0000557 c emu(n) r*8 o cosine of polar backscatter angle 0000558 c emuz(n) r*8 o cosine of solar zenith angles 0000559 c 0000560 c external references 0000561 c none 0000562 c 0000563 c author 0000564 c p. m. smith,sasc,aug 1, 1977 0000565 c modifications 0000566 c (date name purpose) 0000567 c last modified by zia ahmad 9/10/93 0000568 c purpose: to include the effect of molecular anisotropy 0000569 c 0000570 c last modified 03/14/95...dave flittner 0000571 c purpose: set pressure scale height used in gravity correction 0000572 c to rayleigh scattering od. Create new variable pscaleforg and 0000573 c pass in common block consts. 0000574 cccc 0000575 c*********************************************************************** 0000576 c 0000577 implicit integer*4(i-n),real*8(a-h,o-z) 0000578 c 0000579 include "emm.inc" 0000580 include "consts.inc" 0000581 c 0000582 c new statement 0000583 include "depolt.inc" 0000584 c end of new statement 0000585 c 0000586 real*8 thnot(10),thta(15),azmth(8) 0000587 c 0000588 c set up adjoint 0000589 c 0000590 c new statements added in do loops 100 and 200 0000591 c 0000592 do 100 l=1,imuz 0000593 thet=cnvrt*thnot(l) 0000594 emuz(l)=dcos(thet) 0000595 if(ipol.eq.0)then 0000596 admatx(1,l)=emuz(l)*emuz(l) 0000597 admatx(2,l)=1.0d0 0000598 admatx(3,l)=sq2*(1.0d0-admatx(1,l)) 0000599 else 0000600 admatx(1,l)=q+emuz(l)**2 0000601 admatx(2,l)=1.0d0+q 0000602 admatx(3,l)=delp*(1.0d0-emuz(l)**2) 0000603 endif 0000604 100 continue 0000605 c 0000606 c set up m matrix 0000607 c 0000608 do 200 l=1,imu 0000609 thet=cnvrt*thta(l) 0000610 emu(l)=dcos(thet) 0000611 c write(33,555)l,thta(l),emu(l) 0000612 555 format('emmat',i4,1p2e12.4) 0000613 if(ipol.eq.0)then 0000614 ematx(1,l)=emu(l)*emu(l) 0000615 ematx(2,l)=sq2*(1.0d0-ematx(1,l)) 0000616 ematx(3,l)=1.0d0 0000617 else 0000618 ematx(1,l)=q+emu(l)**2 0000619 ematx(2,l)=delp*(1.0d0-emu(l)**2) 0000620 ematx(3,l)=1+q 0000621 endif 0000622 200 continue 0000623 c 0000624 c store trig functions 0000625 c 0000626 do 300 i=1,iazmth 0000627 phi=azmth(i)*cnvrt 0000628 phi2=2.0d0*phi 0000629 saz(i)=dsin(-phi) 0000630 saz2(i)=dsin(-phi2) 0000631 caz(i)=dcos(phi) 0000632 caz2(i)=dcos(phi2) 0000633 300 continue 0000634 return 0000635 end INCLUDE FILES FileNo File name 1 emm.inc 2 consts.inc 3 depolt.inc ENTRY POINTS Name Type BlockNo emmat SUBR 103 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dcos INTRINSIC 594 610 631 632 dsin INTRINSIC 629 630 emmat SUBR 519D COMMON BLOCKS Name Size BlockNo consts_ 112 66 depolt_ 68 70 emm_ 1176 105 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 1-2D 1-4D 596= 597= 598(2)= 600= 601= 602= azmth R*8 (8) VAR ARG 519D 586D 627 c1415 R*8 VAR COMMON 66 72 2-2D 2-4D c215 R*8 VAR COMMON 66 48 2-2D 2-4D c2815 R*8 VAR COMMON 66 80 2-2D 2-4D c38sq2 R*8 VAR COMMON 66 64 2-2D 2-4D c815 R*8 VAR COMMON 66 56 2-2D 2-4D caz R*8 (8) VAR COMMON 105 784 1-2D 1-4D 631= caz2 R*8 (8) VAR COMMON 105 912 1-2D 1-4D 632= cnvrt R*8 VAR COMMON 66 8 2-2D 2-4D 593 609 627 cons R*8 VAR COMMON 66 32 2-2D 2-4D delp R*8 VAR COMMON 70 40 3-3D 3-4D 602 619 ematx R*8 (3,15) VAR COMMON 105 0 1-2D 1-4D 614= 615(2)= 616= 618= 619= 620= emu R*8 (15) VAR COMMON 105 976 1-2D 1-4D 610= 614(2) 618 619 emuz R*8 (10) VAR COMMON 105 1096 1-2D 1-4D 594= 596(2) 600 602 gama R*8 VAR COMMON 70 8 3-3D 3-4D i I*4 VAR AUTO 103 36 626= 627 629 630 631 632 633= iazmth I*4 VAR ARG 519D 626 imu I*4 VAR ARG 519D 608 imuz I*4 VAR ARG 519D 592 ipol I*4 VAR COMMON 70 64 3-2D 3-4D 595 613 kskip R*8 VAR COMMON 66 104 2-2D 2-4D l I*4 VAR AUTO 103 4 592= 593 594 596(3) 597 598(2) 600(2) 601 602(2) 604= 608= 609 610 614(3) 615(2) 616 618(2) 619(2) 620 622= numek R*8 VAR COMMON 66 96 2-2D 2-4D phi R*8 VAR AUTO 103 48 627= 628 629 631A phi2 R*8 VAR AUTO 103 56 628= 630 632A pi R*8 VAR COMMON 66 0 2-2D 2-4D pscaleforg R*8 VAR COMMON 66 88 2-2D 2-4D q R*8 VAR COMMON 70 16 3-3D 3-4D 600 601 618 620 q1 R*8 VAR COMMON 70 24 3-3D 3-4D q12s R*8 VAR COMMON 70 56 3-3D 3-4D q2 R*8 VAR COMMON 70 32 3-3D 3-4D r R*8 VAR COMMON 66 16 2-2D 2-4D rhon R*8 VAR COMMON 70 0 3-3D 3-4D rinv R*8 VAR COMMON 66 24 2-2D 2-4D saz R*8 (8) VAR COMMON 105 720 1-2D 1-4D 629= saz2 R*8 (8) VAR COMMON 105 848 1-2D 1-4D 630= sdp R*8 VAR COMMON 70 48 3-3D 3-4D sq2 R*8 VAR COMMON 66 40 2-2D 2-4D 598 615 thet R*8 VAR AUTO 103 16 593= 594A 609= 610A thnot R*8 (10) VAR ARG 519D 586D 593 thta R*8 (15) VAR ARG 519D 586D 609 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 604 200 622 300 633 555 612 0000636 subroutine eva1pol(zma1,zma2,zma3,zma4,ej1,ej2,jmuz,ncp1,itz) 0000637 c*********************************************************************** 0000638 c 0000639 c subroutine eva1pol 0000640 c 0000641 c purpose 0000642 c 0000643 c last modified 03/14/95...dave flittner 0000644 c purpose: set pressure scale height used in gravity correction 0000645 c to rayleigh scattering od. Create new variable pscaleforg and 0000646 c pass in common block consts. 0000647 c 0000648 c*********************************************************************** 0000649 c 0000650 implicit integer*4 (i-n), real*8(a-h,o-z) 0000651 real*8 ztop(4,4),a(4),b(4),c(4),d(4),ztp1(4),ztp2(4),top(4), 0000652 & dum(8),gr(4),gl(4), 0000653 & zma1(4,202),zma2(4,202),zma3(4,202),zma4(4,202), 0000654 & ej1(4,202),ej2(4,202),hold(4),xhold(4),eiold(15) 0000655 c 0000656 include "out.inc" 0000657 include "emm.inc" 0000658 include "eks.inc" 0000659 include "consts.inc" 0000660 include "contrl.inc" 0000661 include "prints.inc" 0000662 include "in.inc" 0000663 include "buff2.inc" 0000664 c 0000665 c new statement 0000666 include "depolt.inc" 0000667 c end of statement 0000668 c 0000669 data c316/0.1875d0/ 0000670 c 0000671 c extrapolate source functions layer by layer 0000672 c 0000673 itmaxp=itmax+1 0000674 do 300 i=1,ncp1 0000675 if (itz .le. itmaxp) then 0000676 zma1(4,i) = zma1(1,i) 0000677 zma2(4,i) = zma2(1,i) 0000678 zma3(4,i) = zma3(1,i) 0000679 zma4(4,i) = zma4(1,i) 0000680 ej1(4,i) = ej1(1,i) 0000681 ej2(4,i) = ej2(1,i) 0000682 else 0000683 call geopro(zma1(1,i)) 0000684 call geopro(zma2(1,i)) 0000685 call geopro(zma3(1,i)) 0000686 call geopro(zma4(1,i)) 0000687 call geopro(ej1(1,i)) 0000688 call geopro(ej2(1,i)) 0000689 endif 0000690 300 continue 0000691 0000692 c 0000693 c*****put adjoint matrix for current solar zenith angle into b 0000694 c 0000695 b(1)=admatx(1,jmuz) 0000696 b(2)=admatx(2,jmuz) 0000697 b(3)=admatx(3,jmuz) 0000698 b(4)=0.0d0 0000699 c 0000700 do 105 im=1,imu 0000701 it=4 0000702 gr(it)=0.0d0 0000703 gl(it)=0.0d0 0000704 ztp1(it)=0.0d0 0000705 ztp2(it)=0.0d0 0000706 do 107 jd=1,4 0000707 107 ztop(it,jd)=0.0d0 0000708 c 0000709 c*****do integration over optical thickness 0000710 c 0000711 do 110 i=1,ncp1 0000712 tmu=extmu(i,im) 0000713 ztop(it,1)=ztop(it,1)+zma1(it,i)*tmu 0000714 ztop(it,2)=ztop(it,2)+zma2(it,i)*tmu 0000715 ztop(it,3)=ztop(it,3)+zma3(it,i)*tmu 0000716 ztop(it,4)=ztop(it,4)+zma4(it,i)*tmu 0000717 ztp1(it)=ztp1(it)+ej1(it,i)*tmu 0000718 ztp2(it)=ztp2(it)+ej2(it,i)*tmu 0000719 gr(it)=gr(it)+ek4(i)*zma1(it,i)+ek5(i)*zma3(it,i) 0000720 gl(it)=gl(it)+ek4(i)*zma2(it,i)+ek5(i)*zma4(it,i) 0000721 110 continue 0000722 c 0000723 c write(33,132)ipol, ztp1(it),ztp2(it) 0000724 132 format('debug evalit..ipol,ztp1,ztp2',i2,1x,1p2e12.4) 0000725 c 0000726 c*****calculate the azimuth -independent intensity eizero at current 0000727 c*****value of the polar angle. see eqs(3.7) and (4.16) 0000728 c 0000729 c*****multiply matrix top(1-4) times the adjoint matrix admatx(=b). cal 0000730 c*****call the product c 0000731 c 0000732 c 0000733 c*****multiply c by ematx 0000734 c 0000735 a(1)=ematx(1,im) 0000736 a(2)=ematx(2,im) 0000737 a(3)=ematx(3,im) 0000738 a(4)=0.0d0 0000739 c 0000740 c 0000741 c 0000742 do 120 i=1,4 0000743 c 0000744 c**** store extrapolated z-matrix in hold(4) 0000745 c 0000746 hold(i)=ztop(it,i) 0000747 120 continue 0000748 call matmul(hold,b,c) 0000749 call matmul(a,c,d) 0000750 xhold(4)=d(1)+d(2)+d(3)+d(4) 0000751 130 continue 0000752 c new statements added here 0000753 if(ipol.eq.0) then 0000754 eizero(im)=0.09375d0*xhold(4)/emu(im) 0000755 else 0000756 eizero(im)=0.125d0*(q1/sdp)*xhold(4)/emu(im) 0000757 endif 0000758 c 0000759 e0za(itz,im)=eizero(im) 0000760 c 0000761 if(im.eq.1 .and. jprint(4) .eq. 1)then 0000762 write(33,515)itz,im,emu(im),eizero(im),e0za(itz,im) 0000763 515 format('sub eva1pol.itz,im,emu,eizero,e0za',2i5,1x,3f8.5) 0000764 endif 0000765 c 0000766 c*****now calculate azimuth dependent intensities eiaz1 and eiaz2 at all 0000767 c*****azimuth angles (1 to iazmth) for current value of polar angle. 0000768 c***** see eqs.(3.7) and (4.8) 0000769 c 0000770 if(ipol.eq.0)then 0000771 as=ematx(1,im)-1.0d0 0000772 bs=admatx(1,jmuz)-1.0d0 0000773 else 0000774 as=emu(im)*emu(im)-1.0d0 0000775 bs=emuz(jmuz)*emuz(jmuz)-1.0d0 0000776 endif 0000777 c 0000778 atb=as*bs 0000779 absq=dsqrt(atb)*emuz(jmuz) 0000780 atmu=as*emuz(jmuz) 0000781 c 0000782 do 225 jaz=1,iazmth 0000783 c new statements added here 0000784 if(ipol.eq.0)then 0000785 eiaz1(im,jaz)=-0.375d0*absq*caz(jaz)*ztp1(4) 0000786 eiaz2(im,jaz)=0.09375d0*(atb*caz2(jaz))*ztp2(4)/emu(im) 0000787 else 0000788 eiaz1(im,jaz)=-0.375d0*q2*absq*caz(jaz)*ztp1(4) 0000789 eiaz2(im,jaz)=0.09375d0*q2*(atb*caz2(jaz))*ztp2(4)/emu(im) 0000790 endif 0000791 c 0000792 e1za(itz,im,jaz)=eiaz1(im,jaz) 0000793 e2za(itz,im,jaz)=eiaz2(im,jaz) 0000794 c 0000795 c*****compute total intensity at top of atmosphere 0000796 c 0000797 totint(im,jaz)=eizero(im)+eiaz1(im,jaz)+eiaz2(im,jaz) 0000798 c 0000799 if (jprint(4) .eq. 1) 0000800 * write(33,133)itz,im,jaz,eizero(im),eiaz1(im,jaz), 0000801 * eiaz2(im,jaz),totint(im,jaz) 0000802 133 format('eva1.itz,im,jaz,ez0,ez1,ez2,tot',3i4,4f9.4) 0000803 225 continue 0000804 105 continue 0000805 c 0000806 c*****compute the downward diffuse intensity gg 0000807 c 0000808 if(ipol .eq. 0)then 0000809 c gg=c316*(gr(4)*(admatx(1,jmuz)+1.0d0)+gl(4)*admatx(3,jmuz)) 0000810 f1=c316*(admatx(1,jmuz)+1.0d0) 0000811 f2=c316*admatx(3,jmuz) 0000812 gg=f1*gr(4)+f2*gl(4) 0000813 else 0000814 f1=0.25d0*q1*(admatx(1,jmuz)+1.0d0+q) 0000815 f2=0.25d0*q1*admatx(3,jmuz) 0000816 gg=(f1*gr(4)+f2*gl(4))/sdp 0000817 endif 0000818 c 0000819 ggz(itz)=gg 0000820 c for debugging 0000821 if (jprint(4) .eq. 1) write(33,212)gl(4),gr(4),f1,f2,gg 0000822 if (jprint(4) .eq. 1) write(33,312)(e0za(itz,ij),ij=1,imu) 0000823 if (jprint(4) .eq. 1) write(33,313)ggz(itz) 0000824 312 format('e0za',1p6e11.3) 0000825 313 format('ggz',1pe11.3) 0000826 212 format('eva1pol...gl,gr,f1,f2,gg',5f8.4) 0000827 c 0000828 return 0000829 end INCLUDE FILES FileNo File name 1 out.inc 2 emm.inc 3 eks.inc 4 consts.inc 5 contrl.inc 6 prints.inc 7 in.inc 8 buff2.inc 9 depolt.inc ENTRY POINTS Name Type BlockNo eva1pol SUBR 115 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dsqrt INTRINSIC 779 eva1pol SUBR 636D geopro SUBR EXTERNAL 683 684 685 686 687 688 matmul SUBR EXTERNAL 748 749 COMMON BLOCKS Name Size BlockNo buff2_ 18432 128 consts_ 112 66 contrl_ 2808 85 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 in_ 196 126 out_ 3256 117 prints_ 40 124 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (4) VAR AUTO 115 368 651D 735= 736= 737= 738= 749A absq R*8 VAR AUTO 115 528 779= 785 788 admatx R*8 (3,15) VAR COMMON 105 360 2-2D 2-4D 695 696 697 772 810 811 814 815 alb R*8 (11) VAR COMMON 85 200 5-3D 5-5D alfaef R*8 VAR COMMON 85 2792 5-5D as R*8 VAR AUTO 115 504 771= 774= 778 780 atb R*8 VAR AUTO 115 520 778= 779A 786 789 atmu R*8 VAR AUTO 115 536 780= azmth R*8 (8) VAR COMMON 85 136 5-3D 5-5D b R*8 (4) VAR AUTO 115 48 651D 695= 696= 697= 698= 748A bs R*8 VAR AUTO 115 512 772= 775= 778 c R*8 (4) VAR AUTO 115 432 651D 748A 749A c1415 R*8 VAR COMMON 66 72 4-2D 4-4D c215 R*8 VAR COMMON 66 48 4-2D 4-4D c2815 R*8 VAR COMMON 66 80 4-2D 4-4D c316 R*8 VAR DATA 130 0 669I 810 811 c38sq2 R*8 VAR COMMON 66 64 4-2D 4-4D c815 R*8 VAR COMMON 66 56 4-2D 4-4D caz R*8 (8) VAR COMMON 105 784 2-2D 2-4D 785 788 caz2 R*8 (8) VAR COMMON 105 912 2-2D 2-4D 786 789 cnvrt R*8 VAR COMMON 66 8 4-2D 4-4D cons R*8 VAR COMMON 66 32 4-2D 4-4D d R*8 (4) VAR AUTO 115 464 651D 749A 750(4) delp R*8 VAR COMMON 70 40 9-3D 9-4D delx R*8 (10) VAR COMMON 126 0 7-2D 7-4D dum R*8 (8) VAR 651D Variable declared and not used e0za R*8 (9,15) VAR COMMON 128 0 8-2D 8-3D 759= 762 822 e1za R*8 (9,15,8) VAR COMMON 128 1080 8-2D 8-3D 792= e2za R*8 (9,15,8) VAR COMMON 128 9720 8-2D 8-3D 793= eiaz1 R*8 (15,8) VAR COMMON 117 360 1-2D 1-3D 785= 788= 792 797 799 eiaz2 R*8 (15,8) VAR COMMON 117 1320 1-2D 1-3D 786= 789= 793 797 799 eiold R*8 (15) VAR 651D Variable declared and not used eizero R*8 (15) VAR COMMON 117 240 1-2D 1-3D 754= 756= 759 762 797 799 ej1 R*8 (4,202) VAR ARG 636D 651D 680(2)= 687A 717 ej2 R*8 (4,202) VAR ARG 636D 651D 681(2)= 688A 718 ek4 R*8 (202) VAR COMMON 120 24240 3-2D 3-3D 719 720 ek5 R*8 (202) VAR COMMON 120 25856 3-2D 3-3D 719 720 ematx R*8 (3,15) VAR COMMON 105 0 2-2D 2-4D 735 736 737 771 emu R*8 (15) VAR COMMON 105 976 2-2D 2-4D 754 756 762 774(2) 786 789 emuz R*8 (10) VAR COMMON 105 1096 2-2D 2-4D 775(2) 779 780 extmu R*8 (202,15) VAR COMMON 120 0 3-2D 3-3D 712 f1 R*8 VAR AUTO 115 552 810= 812 814= 816 821 f2 R*8 VAR AUTO 115 560 811= 812 815= 816 821 fs R*8 VAR COMMON 117 2288 1-2D 1-3D gama R*8 VAR COMMON 70 8 9-3D 9-4D gg R*8 VAR COMMON 117 2280 1-2D 1-3D 812= 816= 819 821 ggz R*8 (9) VAR COMMON 128 18360 8-2D 8-3D 819= 823 gl R*8 (4) VAR AUTO 115 120 651D 703= 720(2)= 812 816 821 gr R*8 (4) VAR AUTO 115 88 651D 702= 719(2)= 812 816 821 hhold R*8 (101) VAR COMMON 85 1904 5-3D 5-5D hold R*8 (4) VAR AUTO 115 400 651D 746= 748A i I*4 VAR AUTO 115 8 674= 676(2) 677(2) 678(2) 679(2) 680(2) 681(2) 683 684 685 686 687 688 690= 711= 712 713 714 715 716 717 718 719(4) 720(4) 721= 742= 746(2) 747= iazmth I*4 VAR COMMON 85 12 5-2D 5-5D 782 ij I*4 VAR AUTO 115 564 822(3)= im I*4 VAR AUTO 115 52 700= 712 735 736 737 754(2) 756(2) 759(2) 761 762(4) 771 774(2) 785 786(2) 788 789(2) 792(2) 793(2) 797(4) 799(5) 804= imu I*4 VAR COMMON 85 4 5-2D 5-5D 700 822 imuz I*4 VAR COMMON 85 8 5-2D 5-5D ipath I*4 VAR COMMON 126 192 7-3D 7-4D ipol I*4 VAR COMMON 70 64 9-2D 9-4D 753 770 784 808 ipsudo I*4 VAR COMMON 126 188 7-3D 7-4D it I*4 VAR AUTO 115 56 701= 702 703 704 705 707 713(3) 714(3) 715(3) 716(3) 717(3) 718(3) 719(4) 720(4) 746 itmax I*4 VAR COMMON 126 184 7-3D 7-4D 673 itmaxp I*4 VAR AUTO 115 4 673= 675 itz I*4 VAR ARG 636D 675 759 762(2) 792 793 799 819 822 823 jaz I*4 VAR AUTO 115 540 782= 785(2) 786(2) 788(2) 789(2) 792(2) 793(2) 797(3) 799(4) 803= jd I*4 VAR AUTO 115 188 706= 707(2)= jmuz I*4 VAR ARG 636D 695 696 697 772 775(2) 779 780 810 811 814 815 jprint I*4 (10) VAR COMMON 124 0 6-2D 6-3D 761 799 821 822 823 kskip R*8 VAR COMMON 66 104 4-2D 4-4D lambda I*4 VAR COMMON 85 2800 5-2D 5-5D layer I*4 VAR COMMON 85 2804 5-2D 5-5D nalb I*4 VAR COMMON 85 0 5-2D 5-5D ncp1 I*4 VAR ARG 636D 674 711 numek R*8 VAR COMMON 66 96 4-2D 4-4D pi R*8 VAR COMMON 66 0 4-2D 4-4D pscaleforg R*8 VAR COMMON 66 88 4-2D 4-4D pshold R*8 (101) VAR COMMON 85 1096 5-3D 5-5D q R*8 VAR COMMON 70 16 9-3D 9-4D 814 q1 R*8 VAR COMMON 70 24 9-3D 9-4D 756 814 815 q12s R*8 VAR COMMON 70 56 9-3D 9-4D q2 R*8 VAR COMMON 70 32 9-3D 9-4D 788 789 qr R*8 (11) VAR COMMON 117 32 1-2D 1-3D r R*8 VAR COMMON 66 16 4-2D 4-4D rhon R*8 VAR COMMON 70 0 9-3D 9-4D rinv R*8 VAR COMMON 66 24 4-2D 4-4D saz R*8 (8) VAR COMMON 105 720 2-2D 2-4D saz2 R*8 (8) VAR COMMON 105 848 2-2D 2-4D sb R*8 (4) VAR COMMON 117 0 1-2D 1-3D sdp R*8 VAR COMMON 70 48 9-3D 9-4D 756 816 sq2 R*8 VAR COMMON 66 40 4-2D 4-4D thnot R*8 (10) VAR COMMON 85 2712 5-3D 5-5D thta R*8 (15) VAR COMMON 85 16 5-3D 5-5D tmp0 R*8 VAR COMMON 126 176 7-2D 7-4D tmp10 R*8 (10) VAR COMMON 126 88 7-2D 7-4D tmptop R*8 VAR COMMON 126 168 7-2D 7-4D tmu R*8 VAR AUTO 115 336 712= 713 714 715 716 717 718 tnstr R*8 (15) VAR COMMON 117 120 1-2D 1-3D top R*8 (4) VAR 651D Variable declared and not used totint R*8 (15,8) VAR COMMON 117 2296 1-2D 1-3D 797= 799 x R*8 (101) VAR COMMON 85 288 5-3D 5-5D xhold R*8 (4) VAR AUTO 115 496 651D 750= 754 756 xtop R*8 VAR COMMON 126 80 7-2D 7-4D zma1 R*8 (4,202) VAR ARG 636D 651D 676(2)= 683A 713 719 zma2 R*8 (4,202) VAR ARG 636D 651D 677(2)= 684A 714 720 zma3 R*8 (4,202) VAR ARG 636D 651D 678(2)= 685A 715 719 zma4 R*8 (4,202) VAR ARG 636D 651D 679(2)= 686A 716 720 ztop R*8 (4,4) VAR AUTO 115 320 651D 707= 713(2)= 714(2)= 715(2)= 716(2)= 746 ztp1 R*8 (4) VAR AUTO 115 152 651D 704= 717(2)= 785 788 ztp2 R*8 (4) VAR AUTO 115 184 651D 705= 718(2)= 786 789 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 105 804 110 721 130 751 133 802 225 803 312 824 515 763 107 707 120 747 132 724 212 826 300 690 313 825 0000830 subroutine eva2pol(zst1,zst2,ncp1,itz) 0000831 c 0000832 c********************************************************************** 0000833 c 0000834 c subroutine eva2pol 0000835 c 0000836 c this routine is adopted from subroutine evalrf to extract sb,tnstr 0000837 c after each iteration......zia ahmad 10/21/94 0000838 c 0000839 c last modified 03/14/95...dave flittner 0000840 c purpose: set pressure scale height used in gravity correction 0000841 c to rayleigh scattering od. Create new variable pscaleforg and 0000842 c pass in common block consts. 0000843 c*********************************************************************** 0000844 c 0000845 c 0000846 implicit integer*4(i-n),real*8(a-h,o-z) 0000847 real *8 tenstr(4,15),zst1(4,202),zst2(4,202) 0000848 include "emm.inc" 0000849 include "eks.inc" 0000850 include "contrl.inc" 0000851 include "out.inc" 0000852 include "consts.inc" 0000853 include "prints.inc" 0000854 c -- common block in added on 11/19/92 0000855 include "in.inc" 0000856 c common block depolt added on 9/22/93 0000857 include "depolt.inc" 0000858 include "buff1.inc" 0000859 c 0000860 data c316/0.1875d0/ 0000861 c 0000862 c write(23,500)rhon,gama,q,q1,q2,delp,sdp,q12s,ipol 0000863 500 format('rhon,gama,q,q1,q2,delp,sdp,q12s,ipol'/ 0000864 1 1p6e12.4/1p2e12.4,i5) 0000865 c 0000866 c compute gometrical progression of zstar layer by layer 0000867 c 0000868 itmaxp=itmax+1 0000869 do i=1,ncp1 0000870 if (itz .le. itmaxp) then 0000871 zst1(4,i) = zst1(1,i) 0000872 zst2(4,i) = zst2(1,i) 0000873 else 0000874 call geopro(zst1(1,i)) 0000875 call geopro(zst2(1,i)) 0000876 endif 0000877 0000878 enddo 0000879 c 0000880 it=4 0000881 c 0000882 c find sb(it) 0000883 sum2=0.d0 0000884 c 0000885 sum2l=0.0d0 0000886 sum2r=0.0d0 0000887 do 110 i=1,ncp1 0000888 sum2=sum2+ek4(i)*zst1(it,i)+ek5(i)*zst2(it,i) 0000889 110 continue 0000890 c 0000891 c new statements added here 0000892 if(ipol.eq.0)then 0000893 sb(it)=0.375d0*sum2 0000894 else 0000895 sb(it)=q12s*sum2 0000896 endif 0000897 c 0000898 sbz(itz)=sb(it) 0000899 if (jprint(4) .eq. 1) write(33,501)itz,itmax,ipol,sb(it) 0000900 501 format('eva2pol...itz,itmax,ipol,sb',3i5,1pe12.4) 0000901 c find tnstr(it) 0000902 c 0000903 do 120 j=1,imu 0000904 suma=0. 0000905 sumb=0. 0000906 c 0000907 do 130 i=1,ncp1 0000908 suma=suma+zst1(it,i)*extmu(i,j) 0000909 sumb=sumb+zst2(it,i)*extmu(i,j) 0000910 130 continue 0000911 c 0000912 c multiply by m-matrix see eq(6.7) 0000913 c 0000914 tenr=ematx(1,j)*suma+ematx(2,j)*sumb 0000915 tenl=ematx(3,j)*suma 0000916 c 0000917 tensum=tenl+tenr 0000918 c write(33,565)suma,sumb,ematx(1,j),ematx(2,j),ematx(3,j),emu(j), 0000919 c 1 tenl,tenr,tensum 0000920 565 format('evalrf',9f8.5) 0000921 c 0000922 c compute istar/ig of eq (6.7) 0000923 c 0000924 c new statements added here 0000925 if(ipol.eq.0)then 0000926 tnstr(j)=c316*(tenr+tenl)/emu(j) 0000927 tnstrl(j)=c316*tenl/emu(j) 0000928 tnstrr(j)=c316*tenr/emu(j) 0000929 else 0000930 tnstr(j)=0.25d0*(q1/sdp)*(tenr+tenl)/emu(j) 0000931 tnstrl(j)=0.25d0*(q1/sdp)*tenl/emu(j) 0000932 tnstrr(j)=0.25d0*(q1/sdp)*tenr/emu(j) 0000933 endif 0000934 tnstrz(itz,j)=tnstr(j) 0000935 120 continue 0000936 c 0000937 return 0000938 end INCLUDE FILES FileNo File name 1 emm.inc 2 eks.inc 3 contrl.inc 4 out.inc 5 consts.inc 6 prints.inc 7 in.inc 8 depolt.inc 9 buff1.inc ENTRY POINTS Name Type BlockNo eva2pol SUBR 156 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References eva2pol SUBR 830D geopro SUBR EXTERNAL 874 875 COMMON BLOCKS Name Size BlockNo buff1_ 1392 166 consts_ 112 66 contrl_ 2808 85 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 in_ 196 126 out_ 3256 117 prints_ 40 124 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 1-2D 1-4D alb R*8 (11) VAR COMMON 85 200 3-3D 3-5D alfaef R*8 VAR COMMON 85 2792 3-5D azmth R*8 (8) VAR COMMON 85 136 3-3D 3-5D c1415 R*8 VAR COMMON 66 72 5-2D 5-4D c215 R*8 VAR COMMON 66 48 5-2D 5-4D c2815 R*8 VAR COMMON 66 80 5-2D 5-4D c316 R*8 VAR DATA 168 0 860I 926 927 928 c38sq2 R*8 VAR COMMON 66 64 5-2D 5-4D c815 R*8 VAR COMMON 66 56 5-2D 5-4D caz R*8 (8) VAR COMMON 105 784 1-2D 1-4D caz2 R*8 (8) VAR COMMON 105 912 1-2D 1-4D cnvrt R*8 VAR COMMON 66 8 5-2D 5-4D cons R*8 VAR COMMON 66 32 5-2D 5-4D delp R*8 VAR COMMON 70 40 8-3D 8-4D delx R*8 (10) VAR COMMON 126 0 7-2D 7-4D eiaz1 R*8 (15,8) VAR COMMON 117 360 4-2D 4-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 4-2D 4-3D eizero R*8 (15) VAR COMMON 117 240 4-2D 4-3D ek4 R*8 (202) VAR COMMON 120 24240 2-2D 2-3D 888 ek5 R*8 (202) VAR COMMON 120 25856 2-2D 2-3D 888 ematx R*8 (3,15) VAR COMMON 105 0 1-2D 1-4D 914(2) 915 emu R*8 (15) VAR COMMON 105 976 1-2D 1-4D 926 927 928 930 931 932 emuz R*8 (10) VAR COMMON 105 1096 1-2D 1-4D extmu R*8 (202,15) VAR COMMON 120 0 2-2D 2-3D 908 909 fs R*8 VAR COMMON 117 2288 4-2D 4-3D gama R*8 VAR COMMON 70 8 8-3D 8-4D gg R*8 VAR COMMON 117 2280 4-2D 4-3D hhold R*8 (101) VAR COMMON 85 1904 3-3D 3-5D i I*4 VAR AUTO 156 8 869= 871(2) 872(2) 874 875 878= 887= 888(4) 889= 907= 908(2) 909(2) 910= iazmth I*4 VAR COMMON 85 12 3-2D 3-5D imu I*4 VAR COMMON 85 4 3-2D 3-5D 903 imuz I*4 VAR COMMON 85 8 3-2D 3-5D ipath I*4 VAR COMMON 126 192 7-3D 7-4D ipol I*4 VAR COMMON 70 64 8-2D 8-4D 892 899 925 ipsudo I*4 VAR COMMON 126 188 7-3D 7-4D it I*4 VAR AUTO 156 16 880= 888(2) 893 895 898 899 908 909 itmax I*4 VAR COMMON 126 184 7-3D 7-4D 868 899 itmaxp I*4 VAR AUTO 156 4 868= 870 itz I*4 VAR ARG 830D 870 898 899 934 j I*4 VAR AUTO 156 44 903= 908 909 914(2) 915 926(2) 927(2) 928(2) 930(2) 931(2) 932(2) 934(2) 935= jprint I*4 (10) VAR COMMON 124 0 6-2D 6-3D 899 kskip R*8 VAR COMMON 66 104 5-2D 5-4D lambda I*4 VAR COMMON 85 2800 3-2D 3-5D layer I*4 VAR COMMON 85 2804 3-2D 3-5D nalb I*4 VAR COMMON 85 0 3-2D 3-5D ncp1 I*4 VAR ARG 830D 869 887 907 numek R*8 VAR COMMON 66 96 5-2D 5-4D pi R*8 VAR COMMON 66 0 5-2D 5-4D pscaleforg R*8 VAR COMMON 66 88 5-2D 5-4D pshold R*8 (101) VAR COMMON 85 1096 3-3D 3-5D q R*8 VAR COMMON 70 16 8-3D 8-4D q1 R*8 VAR COMMON 70 24 8-3D 8-4D 930 931 932 q12s R*8 VAR COMMON 70 56 8-3D 8-4D 895 q2 R*8 VAR COMMON 70 32 8-3D 8-4D qr R*8 (11) VAR COMMON 117 32 4-2D 4-3D r R*8 VAR COMMON 66 16 5-2D 5-4D rhon R*8 VAR COMMON 70 0 8-3D 8-4D rinv R*8 VAR COMMON 66 24 5-2D 5-4D saz R*8 (8) VAR COMMON 105 720 1-2D 1-4D saz2 R*8 (8) VAR COMMON 105 848 1-2D 1-4D sb R*8 (4) VAR COMMON 117 0 4-2D 4-3D 893= 895= 898 899 sbz R*8 (9) VAR COMMON 166 0 9-2D 9-3D 898= sdp R*8 VAR COMMON 70 48 8-3D 8-4D 930 931 932 sq2 R*8 VAR COMMON 66 40 5-2D 5-4D sum2 R*8 VAR AUTO 156 24 883= 888(2)= 893 895 sum2l R*8 VAR AUTO 156 32 885= sum2r R*8 VAR AUTO 156 40 886= suma R*8 VAR AUTO 156 56 904= 908(2)= 914 915 sumb R*8 VAR AUTO 156 64 905= 909(2)= 914 tenl R*8 VAR AUTO 156 88 915= 917 926 927 930 931 tenr R*8 VAR AUTO 156 80 914= 917 926 928 930 932 tenstr R*8 (4,15) VAR 847D Variable declared and not used tensum R*8 VAR AUTO 156 96 917= thnot R*8 (10) VAR COMMON 85 2712 3-3D 3-5D thta R*8 (15) VAR COMMON 85 16 3-3D 3-5D tmp0 R*8 VAR COMMON 126 176 7-2D 7-4D tmp10 R*8 (10) VAR COMMON 126 88 7-2D 7-4D tmptop R*8 VAR COMMON 126 168 7-2D 7-4D tnstr R*8 (15) VAR COMMON 117 120 4-2D 4-3D 926= 930= 934 tnstrl R*8 (15) VAR COMMON 166 1152 9-2D 9-3D 927= 931= tnstrr R*8 (15) VAR COMMON 166 1272 9-2D 9-3D 928= 932= tnstrz R*8 (9,15) VAR COMMON 166 72 9-2D 9-3D 934= totint R*8 (15,8) VAR COMMON 117 2296 4-2D 4-3D x R*8 (101) VAR COMMON 85 288 3-3D 3-5D xtop R*8 VAR COMMON 126 80 7-2D 7-4D zst1 R*8 (4,202) VAR ARG 830D 847D 871(2)= 874A 888 908 zst2 R*8 (4,202) VAR ARG 830D 847D 872(2)= 875A 888 909 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 110 889 120 935 130 910 500 863 501 900 565 920 0000939 subroutine evalit(zma1,zma2,zma3,zma4,ej1,ej2,jmuz,ncp1) 0000940 c*********************************************************************** 0000941 c 0000942 c subroutine evalit 0000943 c 0000944 c purpose 0000945 c evalit is used to perform the integration of the reduced 0000946 c source functions over the total optical thickness to each 0000947 c level in the model atmosphere. 0000948 c evalit is also used to transfer solar angle dependent data 0000949 c to the archive and tables tapes. 0000950 c 0000951 c method 0000952 c the iterated reduced source functions as calculated by itrate 0000953 c are integrated over the total cumulative optical thickness.the 0000954 c resultant integrated quantities (ztop,ztp1,ztp2,gg) are extrapol 0000955 c extrapolated using a geometric progression. finally certain 0000956 c matrix multiplications are carried out to transform the 0000957 c integrated quantities into intensity terms. 0000958 c 0000959 c calling sequence 0000960 c call evalit(zma1,zma2,zma3,zma4,ej1,ej2,jmuz,ncp1) 0000961 c 0000962 c variable type i/o description 0000963 c -------- ---- --- ----------- 0000964 c 0000965 c zma1(4,202) r*8 i first element of z matrix 0000966 c for each source function 0000967 c level for final three iters. 0000968 c fourth row of this matrix is 0000969 c reserved for extrapolated values. 0000970 c zma2,3,4 r*8 i/o second,third,fourth elements 0000971 c of z matrix. 0000972 c ej1(4,202) r*8 o source functions for cos(phi) 0000973 c dependent terms for last three 0000974 c iterations of itrate. 0000975 c ej2(4,202) r*8 i/o source functions for cos(2*phi) 0000976 c dependent terms. 0000977 c jmuz i*4 i current index counter for zenith 0000978 c angle. 0000979 c ncp1 i*4 i number of levels in model atmos. 0000980 c common /out/ contains intensity terms computed by 0000981 c evalrf,evalit and intsum routines. 0000982 c 0000983 c common /out/ 0000984 c 0000985 c variables type i/o description 0000986 c --------- ---- --- ----------- 0000987 c 0000988 c sb(4) r*8 i fractional atmos. back scatter 0000989 c factor.sb(4) is extrapolated value. 0000990 c tnstr(15) r*8 i extrapolated values of istar/ig for 0000991 c each polar look angle. 0000992 c qr(10) r*8 i combined reflectivity -sb term for 0000993 c all albedo values. 0000994 c eizero(15) r*8 o azimuth independent intensity at each 0000995 c polar look angle. 0000996 c eiaz1(15,8) r*8 o cos(phi) azimuth dependent term for 0000997 c each polar look angle and scan plane 0000998 c angle. 0000999 c eiaz2(15,8) r*8 o cos(2*phi) dependent term for each 0001000 c polar look angle and scan plane angle. 0001001 c gg r*8 o integrated downward diffuse flux at 0001002 c ground for current zenith angle. 0001003 c fs r*8 i direct solar flux at ground for curren 0001004 c current solar zenith angle. 0001005 c totint(15,8) r*8 o total intensity at top of atmosphere 0001006 c for each polar and azimuth angle. 0001007 c 0001008 c analysis and programming k. f. klenk, p. m. smith sasc aug. 77 0001009 c 0001010 c modifications (date name purpose) 0001011 c 0001012 c last modified 11/18/92 by zia ahmad 0001013 c modified for single iteration 0001014 c 0001015 c last modified 9/22/93 ... zia ahmad 0001016 c purpose: to add the effect of molecular depolarization 0001017 c 0001018 c last modified 10/12/94... zia ahmad 0001019 c purpose: modified to compute and print polarization of the 0001020 c diffused radiation. 0001021 c 0001022 c last modified 03/08/95... dave flittner 0001023 c purpose: store Z1func=I1/(-3/8*muo*sqrt(1-muo^2)*sqrt(1-mu^2)) and 0001024 c Z2func=I2/(3/32*(1-muo^2)*(1-mu^2)/mu) so can be used as input into 0001025 c interpolation tables. 0001026 c 0001027 c last modified 03/14/95...dave flittner 0001028 c purpose: set pressure scale height used in gravity correction 0001029 c to rayleigh scattering od. Create new variable pscaleforg and 0001030 c pass in common block consts. 0001031 c*********************************************************************** 0001032 c 0001033 implicit integer*4 (i-n), real*8(a-h,o-z) 0001034 real*8 ztop(4,4),a(4),b(4),c(4),d(4),ztp1(4),ztp2(4),top(4), 0001035 & dum(8),gr(4),gl(4), 0001036 & zma1(4,202),zma2(4,202),zma3(4,202),zma4(4,202), 0001037 & ej1(4,202),ej2(4,202),hold(4),xhold(4),eiold(15) 0001038 real*8 eiaz1l(15,8),eiaz1r(15,8),eiaz1u(15,8), 0001039 1 eiaz2l(15,8),eiaz2r(15,8),eiaz2u(15,8),pol(15,8), 0001040 2 eizrol(15),eizror(15) 0001041 c 0001042 include "tabbuf.inc" 0001043 include "hedout.inc" 0001044 include "out.inc" 0001045 include "emm.inc" 0001046 include "eks.inc" 0001047 include "consts.inc" 0001048 include "contrl.inc" 0001049 include "prints.inc" 0001050 include "in.inc" 0001051 include "buff3.inc" 0001052 include "czfunc.inc" 0001053 c new statement 0001054 include "depolt.inc" 0001055 c end of statement 0001056 c 0001057 dimension raray(906) 0001058 equivalence (rarray(1),raray(1)) 0001059 c 0001060 data c316/0.1875d0/ 0001061 c extrapolate source functions layer by layer 0001062 c 0001063 do 300 i=1,ncp1 0001064 if (itmax.eq.1) then 0001065 zma1(4,i) = zma1(1,i) 0001066 zma2(4,i) = zma2(1,i) 0001067 zma3(4,i) = zma3(1,i) 0001068 zma4(4,i) = zma4(1,i) 0001069 ej1(4,i) = ej1(1,i) 0001070 ej2(4,i) = ej2(1,i) 0001071 else 0001072 call geopro(zma1(1,i)) 0001073 call geopro(zma2(1,i)) 0001074 call geopro(zma3(1,i)) 0001075 call geopro(zma4(1,i)) 0001076 call geopro(ej1(1,i)) 0001077 call geopro(ej2(1,i)) 0001078 endif 0001079 300 continue 0001080 c 0001081 c*****put adjoint matrix for current solar zenith angle into b 0001082 c 0001083 b(1)=admatx(1,jmuz) 0001084 b(2)=admatx(2,jmuz) 0001085 b(3)=admatx(3,jmuz) 0001086 b(4)=0.0d0 0001087 c 0001088 if(jprint(1).eq.1) write(33,1000) 0001089 do 105 im=1,imu 0001090 it=4 0001091 gr(it)=0.0d0 0001092 gl(it)=0.0d0 0001093 ztp1(it)=0.0d0 0001094 ztp2(it)=0.0d0 0001095 do 107 jd=1,4 0001096 107 ztop(it,jd)=0.0d0 0001097 c 0001098 c*****do integration over optical thickness 0001099 c 0001100 do 110 i=1,ncp1 0001101 tmu=extmu(i,im) 0001102 ztop(it,1)=ztop(it,1)+zma1(it,i)*tmu 0001103 ztop(it,2)=ztop(it,2)+zma2(it,i)*tmu 0001104 ztop(it,3)=ztop(it,3)+zma3(it,i)*tmu 0001105 ztop(it,4)=ztop(it,4)+zma4(it,i)*tmu 0001106 ztp1(it)=ztp1(it)+ej1(it,i)*tmu 0001107 ztp2(it)=ztp2(it)+ej2(it,i)*tmu 0001108 gr(it)=gr(it)+ek4(i)*zma1(it,i)+ek5(i)*zma3(it,i) 0001109 gl(it)=gl(it)+ek4(i)*zma2(it,i)+ek5(i)*zma4(it,i) 0001110 110 continue 0001111 if(ipol.eq.0)then !def 0001112 Z1func(im)=ztp1(4) !def 0001113 Z2func(im)=ztp2(4) !def 0001114 else !def 0001115 Z1func(im)=q2*ztp1(4) !def 0001116 Z2func(im)=q2*ztp2(4) !def 0001117 endif !def 0001118 100 continue 0001119 c 0001120 c write(33,132)ipol, ztp1(it),ztp2(it) 0001121 132 format('debug evalit..ipol,ztp1,ztp2',i2,1x,1p2e12.4) 0001122 c 0001123 c*****calculate the azimuth -independent intensity eizero at current 0001124 c*****value of the polar angle. see eqs(3.7) and (4.16) 0001125 c 0001126 c*****multiply matrix top(1-4) times the adjoint matrix admatx(=b). cal 0001127 c*****call the product c 0001128 c 0001129 c 0001130 c*****multiply c by ematx 0001131 c 0001132 a(1)=ematx(1,im) 0001133 a(2)=ematx(2,im) 0001134 a(3)=ematx(3,im) 0001135 a(4)=0.0d0 0001136 c 0001137 c 0001138 c 0001139 do 120 i=1,4 0001140 c 0001141 c**** store extrapolated z-matrix in hold(4) 0001142 c 0001143 hold(i)=ztop(it,i) 0001144 120 continue 0001145 call matmul(hold,b,c) 0001146 call matmul(a,c,d) 0001147 xhold(4)=d(1)+d(2)+d(3)+d(4) 0001148 130 continue 0001149 c new statements added here 0001150 if(ipol.eq.0) then 0001151 eizero(im)=0.09375d0*xhold(4)/emu(im) 0001152 eizrol(im)=0.09375d0*(d(1)+d(2))/emu(im) 0001153 eizror(im)=0.09375d0*(d(3)+d(4))/emu(im) 0001154 else 0001155 eizero(im)=0.125d0*(q1/sdp)*xhold(4)/emu(im) 0001156 eizrol(im)=0.125d0*(q1/sdp)*(d(1)+d(2))/emu(im) 0001157 eizror(im)=0.125d0*(q1/sdp)*(d(3)+d(4))/emu(im) 0001158 endif 0001159 c 0001160 c if(im.eq.1)then 0001161 if (jprint(1) .eq. 1) write(33,514)im,emu(im), 0001162 * d(1),d(2),d(3),d(4) 0001163 514 format('im,emu,d1,d2,d3,d4',i3,1x,5f8.4) 0001164 if (jprint(1) .eq. 1) write(33,515)im,emu(im), 0001165 * eizero(im),eizrol(im),eizror(im) 0001166 515 format('evalitpol..im,emu,ei0,eil,eir',1x,i2,1x,4f8.5) 0001167 c endif 0001168 c 0001169 c*****now calculate azimuth dependent intensities eiaz1 and eiaz2 at all 0001170 c*****azimuth angles (1 to iazmth) for current value of polar angle. 0001171 c***** see eqs.(3.7) and (4.8) 0001172 c 0001173 if(ipol.eq.0)then 0001174 as=ematx(1,im)-1.0d0 0001175 bs=admatx(1,jmuz)-1.0d0 0001176 else 0001177 as=emu(im)*emu(im)-1.0d0 0001178 bs=emuz(jmuz)*emuz(jmuz)-1.0d0 0001179 endif 0001180 c 0001181 cs=emu(im)*emu(im) 0001182 atb=as*bs 0001183 absq=dsqrt(atb)*emuz(jmuz) 0001184 atmu=as*emuz(jmuz) 0001185 c 0001186 c write(33,134) ipol,im,jmuz,as,bs,atb,absq,atmu 0001187 134 format('ipol,as,bs,atb,absq,atmu'/3i2,1x,1p5e12.4) 0001188 c 0001189 do 225 jaz=1,iazmth 0001190 c new statements added here 0001191 if(ipol.eq.0)then 0001192 eiaz1(im,jaz)=-0.375d0*absq*caz(jaz)*ztp1(4) 0001193 eiaz2(im,jaz)=0.09375d0*(atb*caz2(jaz))*ztp2(4)/emu(im) 0001194 c new code for polarization 0001195 eiaz1l(im,jaz)=eiaz1(im,jaz) 0001196 eiaz1r(im,jaz)=0.0d0 0001197 eiaz1u(im,jaz)=0.375d0*absq*dsqrt(1.0d0-caz(jaz)**2)* 0001198 1 ztp1(4)/emu(im) 0001199 eiaz2l(im,jaz)=0.09375d0*cs*bs*caz2(jaz)*ztp2(4)/emu(im) 0001200 eiaz2r(im,jaz)=-0.09375d0*bs*caz2(jaz)*ztp2(4)/emu(im) 0001201 eiaz2u(im,jaz)=-0.09375d0*bs* 0001202 1 dsqrt(1.0d0-caz2(jaz)**2)*ztp2(4) 0001203 else 0001204 eiaz1(im,jaz)=-0.375d0*q2*absq*caz(jaz)*ztp1(4) 0001205 eiaz2(im,jaz)=0.09375d0*q2*(atb*caz2(jaz))*ztp2(4)/emu(im) 0001206 c new code for polarization 0001207 eiaz1l(im,jaz)=eiaz1(im,jaz) 0001208 eiaz1r(im,jaz)=0.0d0 0001209 eiaz1u(im,jaz)=0.375d0*q2*absq*dsqrt(1.0d0-caz(jaz)**2)* 0001210 1 ztp1(4)/emu(im) 0001211 eiaz2l(im,jaz)=0.09375d0*q2*cs*bs*caz2(jaz)*ztp2(4)/emu(im) 0001212 eiaz2r(im,jaz)=-0.09375d0*q2*bs*caz2(jaz)*ztp2(4)/emu(im) 0001213 eiaz2u(im,jaz)=-0.09375d0*q2*bs* 0001214 1 dsqrt(1.0d0-caz2(jaz)**2)*ztp2(4) 0001215 endif 0001216 c 0001217 c*****compute total intensity at top of atmosphere 0001218 c 0001219 totint(im,jaz)=eizero(im)+eiaz1(im,jaz)+eiaz2(im,jaz) 0001220 c 0001221 c compute degree of polarization 0001222 eitl(im,jaz)=eizrol(im)+eiaz1l(im,jaz)+eiaz2l(im,jaz) 0001223 eitr(im,jaz)=eizror(im)+eiaz1r(im,jaz)+eiaz2r(im,jaz) 0001224 eitu(im,jaz)=eiaz1u(im,jaz)+eiaz2u(im,jaz) 0001225 pol(im,jaz)=dsqrt((eitl(im,jaz)-eitr(im,jaz))**2 0001226 1 +eitu(im,jaz)**2)/totint(im,jaz) 0001227 c 0001228 if (jprint(1) .eq. 1) write(33,133)im,jaz,eizero(im), 0001229 * eiaz1(im,jaz),eiaz2(im,jaz),totint(im,jaz),pol(im,jaz) 0001230 133 format('evalitpol...im,jaz,ei0,ei1,ei2,totint,pol'/ 0001231 1 2i4,1p5e11.3) 0001232 if (jprint(1) .eq. 1) write(33,136)eitl(im,jaz),eitr(im,jaz), 0001233 * eitu(im,jaz) 0001234 136 format(8x,1p3e11.3) 0001235 225 continue 0001236 if(jprint(1).eq.1) write(33,1100)im,thta(im), 0001237 1 (ztop(4,j),j=1,4),ztp1(4),ztp2(4) 0001238 105 continue 0001239 if(jprint(1).eq.1) write(33,2000) gl(4),gr(4) 0001240 c 0001241 c*****compute the downward diffuse intensity gg 0001242 c 0001243 if(ipol .eq. 0)then 0001244 c gg=c316*(gr(4)*(admatx(1,jmuz)+1.0d0)+gl(4)*admatx(3,jmuz)) 0001245 f1=c316*(admatx(1,jmuz)+1.0d0) 0001246 f2=c316*admatx(3,jmuz) 0001247 gg=f1*gr(4)+f2*gl(4) 0001248 else 0001249 f1=0.25d0*q1*(admatx(1,jmuz)+1.0d0+q) 0001250 f2=0.25d0*q1*admatx(3,jmuz) 0001251 gg=(f1*gr(4)+f2*gl(4))/sdp 0001252 endif 0001253 c 0001254 c for debugging 0001255 c write(33,212)gl(4),gr(4),f1,f2,gg,q 0001256 212 format('gl,gr,f1,f2,gg,q',6f8.4) 0001257 c write(33,213)(admatx(iz,jmuz),iz=1,3) 0001258 213 format(1x,'admatx 1-3',3f8.4) 0001259 c 0001260 c**** store data for archive tape 0001261 raray(1)=fs 0001262 raray(2)=gg 0001263 k1=3 0001264 do 400 i=1,ncp1 0001265 k5=810+i 0001266 k6=1012+i 0001267 raray(k1)=zma1(4,i) 0001268 raray(k1+1)=zma2(4,i) 0001269 raray(k1+2)=zma3(4,i) 0001270 raray(k1+3)=zma4(4,i) 0001271 raray(k5)=ej1(4,i) 0001272 raray(k6)=ej2(4,i) 0001273 k1=k1+4 0001274 400 continue 0001275 C write (34) raray,iarray 0001276 c out48(1)=thnot(jmuz) 0001277 c j=2 0001278 c do 420 i=1,15 0001279 c out48(j)=eizero(i) 0001280 c out48(j+15)=eiaz1(i,1) 0001281 c out48(j+30)=eiaz2(i,1) 0001282 c j=j+1 0001283 c 420 continue 0001284 c out48(47)=fs 0001285 c out48(48)=gg 0001286 c write(35)out48 0001287 500 continue 0001288 c**** call intsum to compute total intensity 0001289 call intsum 0001290 if (jprint(10).eq.1) call sumry(jmuz) 0001291 return 0001292 1000 format(1h1,t5,'debug print out from evalit',10x, 0001293 1 'source functions(extrapolated) integrated over', 0001294 2 1x,'optical thickness',///, 0001295 2 1x,'imu',2x,'theta',5x,'ztop1',9x,'ztop2',9x,'ztop3',9x, 0001296 3 'ztop4',9x,' ztp1',9x,' ztp2',//) 0001297 1100 format(1x,i3,2x,f5.2,2x,d12.6,2x,d12.6,2x,d12.6,2x,d12.6, 0001298 1 2x,d12.6,2x,d12.6) 0001299 2000 format(///,1x,'gl= ',d12.6,/,1x,'gr= ',d12.6) 0001300 end INCLUDE FILES FileNo File name 1 tabbuf.inc 2 hedout.inc 3 out.inc 4 emm.inc 5 eks.inc 6 consts.inc 7 contrl.inc 8 prints.inc 9 in.inc 10 buff3.inc 11 czfunc.inc 12 depolt.inc ENTRY POINTS Name Type BlockNo evalit SUBR 176 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dsqrt INTRINSIC 1183 1197 1201 1209 1213 1225 evalit SUBR 939D geopro SUBR EXTERNAL 1072 1073 1074 1075 1076 1077 intsum SUBR EXTERNAL 1289 matmul SUBR EXTERNAL 1145 1146 sumry SUBR EXTERNAL 1290 COMMON BLOCKS Name Size BlockNo buff3_ 3120 188 consts_ 112 66 contrl_ 2808 85 czfunc_ 240 190 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 hedout_ 7260 89 in_ 196 126 out_ 3256 117 prints_ 40 124 tabbuf_ 192 178 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (4) VAR AUTO 176 360 1034D 1132= 1133= 1134= 1135= 1146A absq R*8 VAR AUTO 176 768 1183= 1192 1197 1204 1209 admatx R*8 (3,15) VAR COMMON 105 360 4-2D 4-4D 1083 1084 1085 1175 1245 1246 1249 1250 alb R*8 (11) VAR COMMON 85 200 7-3D 7-5D alfaef R*8 VAR COMMON 85 2792 7-5D as R*8 VAR AUTO 176 736 1174= 1177= 1182 1184 atb R*8 VAR AUTO 176 760 1182= 1183A 1193 1205 atmu R*8 VAR AUTO 176 776 1184= azmth R*8 (8) VAR COMMON 85 136 7-3D 7-5D b R*8 (4) VAR AUTO 176 40 1034D 1083= 1084= 1085= 1086= 1145A bs R*8 VAR AUTO 176 744 1175= 1178= 1182 1199 1200 1201 1211 1212 1213 c R*8 (4) VAR AUTO 176 424 1034D 1145A 1146A c1415 R*8 VAR COMMON 66 72 6-2D 6-4D c215 R*8 VAR COMMON 66 48 6-2D 6-4D c2815 R*8 VAR COMMON 66 80 6-2D 6-4D c316 R*8 VAR DATA 192 0 1060I 1245 1246 c38sq2 R*8 VAR COMMON 66 64 6-2D 6-4D c815 R*8 VAR COMMON 66 56 6-2D 6-4D caz R*8 (8) VAR COMMON 105 784 4-2D 4-4D 1192 1197 1204 1209 caz2 R*8 (8) VAR COMMON 105 912 4-2D 4-4D 1193 1199 1200 1201 1205 1211 1212 1213 cnvrt R*8 VAR COMMON 66 8 6-2D 6-4D cons R*8 VAR COMMON 66 32 6-2D 6-4D cs R*8 VAR AUTO 176 752 1181= 1199 1211 d R*8 (4) VAR AUTO 176 456 1034D 1146A 1147(4) 1152(2) 1153(2) 1156(2) 1157(2) 1161(4) delp R*8 VAR COMMON 70 40 12-3D 12-4D delx R*8 (10) VAR COMMON 126 0 9-2D 9-4D dum R*8 (8) VAR 1034D Variable declared and not used eiaz1 R*8 (15,8) VAR COMMON 117 360 3-2D 3-3D 1192= 1195 1204= 1207 1219 1228 eiaz1l R*8 (15,8) VAR AUTO 176 1744 1038D 1195= 1207= 1222 eiaz1r R*8 (15,8) VAR AUTO 176 2704 1038D 1196= 1208= 1223 eiaz1u R*8 (15,8) VAR AUTO 176 3664 1038D 1197= 1209= 1224 eiaz2 R*8 (15,8) VAR COMMON 117 1320 3-2D 3-3D 1193= 1205= 1219 1228 eiaz2l R*8 (15,8) VAR AUTO 176 4632 1038D 1199= 1211= 1222 eiaz2r R*8 (15,8) VAR AUTO 176 5592 1038D 1200= 1212= 1223 eiaz2u R*8 (15,8) VAR AUTO 176 6552 1038D 1201= 1213= 1224 eiold R*8 (15) VAR 1034D Variable declared and not used eitl R*8 (15,8) VAR COMMON 188 0 10-2D 10-3D 1222= 1225 1232 eitr R*8 (15,8) VAR COMMON 188 960 10-2D 10-3D 1223= 1225 1232 eitu R*8 (15,8) VAR COMMON 188 1920 10-2D 10-3D 1224= 1225 1232 eizero R*8 (15) VAR COMMON 117 240 3-2D 3-3D 1151= 1155= 1164 1219 1228 eizrol R*8 (15) VAR AUTO 176 608 1038D 1152= 1156= 1164 1222 eizror R*8 (15) VAR AUTO 176 728 1038D 1153= 1157= 1164 1223 ej1 R*8 (4,202) VAR ARG 939D 1034D 1069(2)= 1076A 1106 1271 ej2 R*8 (4,202) VAR ARG 939D 1034D 1070(2)= 1077A 1107 1272 ek4 R*8 (202) VAR COMMON 120 24240 5-2D 5-3D 1108 1109 ek5 R*8 (202) VAR COMMON 120 25856 5-2D 5-3D 1108 1109 ematx R*8 (3,15) VAR COMMON 105 0 4-2D 4-4D 1132 1133 1134 1174 emu R*8 (15) VAR COMMON 105 976 4-2D 4-4D 1151 1152 1153 1155 1156 1157 1161 1164 1177(2) 1181(2) 1193 1197 1199 1200 1205 1209 1211 1212 emuz R*8 (10) VAR COMMON 105 1096 4-2D 4-4D 1178(2) 1183 1184 extmu R*8 (202,15) VAR COMMON 120 0 5-2D 5-3D 1101 f1 R*8 VAR AUTO 176 7536 1245= 1247 1249= 1251 f2 R*8 VAR AUTO 176 7544 1246= 1247 1250= 1251 fs R*8 VAR COMMON 117 2288 3-2D 3-3D 1261 gama R*8 VAR COMMON 70 8 12-3D 12-4D gg R*8 VAR COMMON 117 2280 3-2D 3-3D 1247= 1251= 1262 gl R*8 (4) VAR AUTO 176 112 1034D 1092= 1109(2)= 1239 1247 1251 gr R*8 (4) VAR AUTO 176 80 1034D 1091= 1108(2)= 1239 1247 1251 hhold R*8 (101) VAR COMMON 85 1904 7-3D 7-5D hold R*8 (4) VAR AUTO 176 392 1034D 1143= 1145A i I*4 VAR AUTO 176 4 1063= 1065(2) 1066(2) 1067(2) 1068(2) 1069(2) 1070(2) 1072 1073 1074 1075 1076 1077 1079= 1100= 1101 1102 1103 1104 1105 1106 1107 1108(4) 1109(4) 1110= 1139= 1143(2) 1144= 1264= 1265 1266 1267 1268 1269 1270 1271 1272 1274= iarray I*4 (3) VAR COMMON 89 7248 2-2D 2-4D iazmth I*4 VAR COMMON 85 12 7-2D 7-5D 1189 im I*4 VAR AUTO 176 44 1089= 1101 1112 1113 1115 1116 1132 1133 1134 1151(2) 1152(2) 1153(2) 1155(2) 1156(2) 1157(2) 1161(2) 1164(5) 1174 1177(2) 1181(2) 1192 1193(2) 1195(2) 1196 1197(2) 1199(2) 1200(2) 1201 1204 1205(2) 1207(2) 1208 1209(2) 1211(2) 1212(2) 1213 1219(4) 1222(4) 1223(4) 1224(3) 1225(5) 1228(6) 1232(3) 1236(2) 1238= imu I*4 VAR COMMON 85 4 7-2D 7-5D 1089 imuz I*4 VAR COMMON 85 8 7-2D 7-5D ipath I*4 VAR COMMON 126 192 9-3D 9-4D ipol I*4 VAR COMMON 70 64 12-2D 12-4D 1111 1150 1173 1191 1243 ipsudo I*4 VAR COMMON 126 188 9-3D 9-4D it I*4 VAR AUTO 176 48 1090= 1091 1092 1093 1094 1096 1102(3) 1103(3) 1104(3) 1105(3) 1106(3) 1107(3) 1108(4) 1109(4) 1143 itmax I*4 VAR COMMON 126 184 9-3D 9-4D 1064 j I*4 VAR AUTO 176 7524 1236(3)= jaz I*4 VAR AUTO 176 780 1189= 1192(2) 1193(2) 1195(2) 1196 1197(2) 1199(2) 1200(2) 1201(2) 1204(2) 1205(2) 1207(2) 1208 1209(2) 1211(2) 1212(2) 1213(2) 1219(3) 1222(3) 1223(3) 1224(3) 1225(5) 1228(5) 1232(3) 1235= jd I*4 VAR AUTO 176 180 1095= 1096(2)= jmuz I*4 VAR ARG 939D 1083 1084 1085 1175 1178(2) 1183 1184 1245 1246 1249 1250 1290A jprint I*4 (10) VAR COMMON 124 0 8-2D 8-3D 1088 1161 1164 1228 1232 1236 1239 1290 k1 I*4 VAR AUTO 176 7548 1263= 1267 1268 1269 1270 1273(2)= k5 I*4 VAR AUTO 176 7552 1265= 1271 k6 I*4 VAR AUTO 176 7556 1266= 1272 kskip R*8 VAR COMMON 66 104 6-2D 6-4D lambda I*4 VAR COMMON 85 2800 7-2D 7-5D layer I*4 VAR COMMON 85 2804 7-2D 7-5D nalb I*4 VAR COMMON 85 0 7-2D 7-5D ncp1 I*4 VAR ARG 939D 1063 1100 1264 numek R*8 VAR COMMON 66 96 6-2D 6-4D out48 R*4 (48) VAR COMMON 178 0 1-2D 1-3D pi R*8 VAR COMMON 66 0 6-2D 6-4D pol R*8 (15,8) VAR AUTO 176 7512 1038D 1225= 1228 psaray R*8 (82) VAR COMMON 89 6592 2-3D 2-4D pscaleforg R*8 VAR COMMON 66 88 6-2D 6-4D pshold R*8 (101) VAR COMMON 85 1096 7-3D 7-5D q R*8 VAR COMMON 70 16 12-3D 12-4D 1249 q1 R*8 VAR COMMON 70 24 12-3D 12-4D 1155 1156 1157 1249 1250 q12s R*8 VAR COMMON 70 56 12-3D 12-4D q2 R*8 VAR COMMON 70 32 12-3D 12-4D 1115 1116 1204 1205 1209 1211 1212 1213 qr R*8 (11) VAR COMMON 117 32 3-2D 3-3D r R*8 VAR COMMON 66 16 6-2D 6-4D raray R*8 (906) VAR COMMON 89 0 1057D 1058D 1261= 1262= 1267= 1268= 1269= 1270= 1271= 1272= rarray R*8 (824) VAR COMMON 89 0 2-3D 2-4D 1058D rhon R*8 VAR COMMON 70 0 12-3D 12-4D rinv R*8 VAR COMMON 66 24 6-2D 6-4D saz R*8 (8) VAR COMMON 105 720 4-2D 4-4D saz2 R*8 (8) VAR COMMON 105 848 4-2D 4-4D sb R*8 (4) VAR COMMON 117 0 3-2D 3-3D sdp R*8 VAR COMMON 70 48 12-3D 12-4D 1155 1156 1157 1251 sq2 R*8 VAR COMMON 66 40 6-2D 6-4D thnot R*8 (10) VAR COMMON 85 2712 7-3D 7-5D thta R*8 (15) VAR COMMON 85 16 7-3D 7-5D 1236 tmp0 R*8 VAR COMMON 126 176 9-2D 9-4D tmp10 R*8 (10) VAR COMMON 126 88 9-2D 9-4D tmptop R*8 VAR COMMON 126 168 9-2D 9-4D tmu R*8 VAR AUTO 176 328 1101= 1102 1103 1104 1105 1106 1107 tnstr R*8 (15) VAR COMMON 117 120 3-2D 3-3D top R*8 (4) VAR 1034D Variable declared and not used totint R*8 (15,8) VAR COMMON 117 2296 3-2D 3-3D 1219= 1225 1228 ttlp R*8 (15) VAR COMMON 188 2880 10-2D 10-3D ttrp R*8 (15) VAR COMMON 188 3000 10-2D 10-3D x R*8 (101) VAR COMMON 85 288 7-3D 7-5D xhold R*8 (4) VAR AUTO 176 488 1034D 1147= 1151 1155 xtop R*8 VAR COMMON 126 80 9-2D 9-4D z1func R*8 (15) VAR COMMON 190 0 11-2D 11-3D 1112= 1115= z2func R*8 (15) VAR COMMON 190 120 11-2D 11-3D 1113= 1116= zma1 R*8 (4,202) VAR ARG 939D 1034D 1065(2)= 1072A 1102 1108 1267 zma2 R*8 (4,202) VAR ARG 939D 1034D 1066(2)= 1073A 1103 1109 1268 zma3 R*8 (4,202) VAR ARG 939D 1034D 1067(2)= 1074A 1104 1108 1269 zma4 R*8 (4,202) VAR ARG 939D 1034D 1068(2)= 1075A 1105 1109 1270 ztop R*8 (4,4) VAR AUTO 176 312 1034D 1096= 1102(2)= 1103(2)= 1104(2)= 1105(2)= 1143 1236 ztp1 R*8 (4) VAR AUTO 176 144 1034D 1093= 1106(2)= 1112 1115 1192 1197 1204 1209 1236 ztp2 R*8 (4) VAR AUTO 176 176 1034D 1094= 1107(2)= 1113 1116 1193 1199 1200 1201 1205 1211 1212 1213 1236 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 1118 110 1110 132 1121 136 1234 225 1235 500 1287 1000 1292 105 1238 120 1144 133 1230 212 1256 300 1079 514 1163 1100 1297 107 1096 130 1148 134 1187 213 1258 400 1274 515 1166 2000 1299 0001301 subroutine evalrf(zst1,zst2,ncp1) 0001302 c 0001303 c********************************************************************** 0001304 c 0001305 cccc 0001306 c subroutine evalrf 0001307 c 0001308 c version aug 22,1977 0001309 c 0001310 c purpose 0001311 c 0001312 c evalrf is a fortran iv routine which is used to perfform 0001313 c the integration of eq(6.7) to find tnstr (istar/ig) 0001314 c 0001315 c method 0001316 c 0001317 c using a trapezoidal integration , evalrf computes tenstr which 0001318 c represents the sum of all intensities upto and including the 0001319 c intensity due to itmax+1 order scattering of surface reflected 0001320 c radiation. 0001321 c the remaining higher order terms are calulated by gepro. 0001322 c 0001323 c calling sequence 0001324 c 0001325 c call evalrf (zst1,zst2,tnstr,qr,sb) 0001326 c 0001327 c variable type i/o description 0001328 c -------- ---- --- ----------- 0001329 c 0001330 c zst1(4,202) r*8 i last three iterations of 0001331 c zstar matrix and extrapolated value 0001332 c zst2(4,202) r** i similar to zst1 0001333 c tnstr(4,15) r*8 o integrated intensities from last 0001334 c three iterations of z-star matrix 0001335 c and extrapolated intensity. 0001336 c contains results for each polar 0001337 c look angle 0001338 c qr(11) r*8 o factor used in computing ig 0001339 c sb(4) r*8 o fraction of surface recflected 0001340 c radiation reaching top of atmosphere 0001341 c 0001342 c external references 0001343 c geopro 0001344 c 0001345 c common areas referenced 0001346 c 0001347 c 0001348 c analysis and programming 0001349 c k.f. klenk,p.m. smith sasc, aug 22 1977 0001350 c 0001351 c modifications (date name purpose) 0001352 c 0001353 c last modified 11/19/92 by zia ahmad 0001354 c modified for single iteration 0001355 c last modified 9/22/93 .... zia ahmad 0001356 c purpose: to add the effect of molecular anisotropy 0001357 c 0001358 c last modified 03/14/95...dave flittner 0001359 c purpose: set pressure scale height used in gravity correction 0001360 c to rayleigh scattering od. Create new variable pscaleforg and 0001361 c pass in common block consts. 0001362 cccc 0001363 c*********************************************************************** 0001364 c 0001365 c 0001366 implicit integer*4(i-n),real*8(a-h,o-z) 0001367 real *8 tenstr(4,15),zst1(4,202),zst2(4,202) 0001368 c 0001369 include "hedout.inc" 0001370 include "tabbuf.inc" 0001371 include "emm.inc" 0001372 include "eks.inc" 0001373 include "contrl.inc" 0001374 include "consts.inc" 0001375 include "out.inc" 0001376 include "prints.inc" 0001377 c -- common block in added on 11/19/92 0001378 include "in.inc" 0001379 c common block depolt added on 9/22/93 0001380 include "depolt.inc" 0001381 c 0001382 data c316/0.1875d0/ 0001383 c 0001384 c write(23,500)rhon,gama,q,q1,q2,delp,sdp,q12s,ipol 0001385 500 format('rhon,gama,q,q1,q2,delp,sdp,q12s,ipol'/ 0001386 1 1p6e12.4/1p2e12.4,i5) 0001387 c 0001388 c compute gometrical progression of zstar layer by layer 0001389 c 0001390 do 160 i=1,ncp1 0001391 if (itmax.eq.1) then 0001392 zst1(4,i) = zst1(1,i) 0001393 zst2(4,i) = zst2(1,i) 0001394 else 0001395 call geopro(zst1(1,i)) 0001396 call geopro(zst2(1,i)) 0001397 endif 0001398 160 continue 0001399 c 0001400 it=4 0001401 c 0001402 c find sb(it) 0001403 sum2=0.d0 0001404 c 0001405 sum2l=0.0d0 0001406 sum2r=0.0d0 0001407 do 110 i=1,ncp1 0001408 sum2=sum2+ek4(i)*zst1(it,i)+ek5(i)*zst2(it,i) 0001409 110 continue 0001410 c 0001411 c new statements added here 0001412 if(ipol.eq.0)then 0001413 sb(it)=0.375d0*sum2 0001414 else 0001415 sb(it)=q12s*sum2 0001416 endif 0001417 c 0001418 if (jprint(10).eq.1) write(23,501)sb,ipol 0001419 if (jprint(2) .eq. 1) write(33,501)sb,ipol 0001420 501 format('evalrf..sb,ipol',1p4e12.4,i5) 0001421 c find tnstr(it) 0001422 c 0001423 do 120 j=1,imu 0001424 suma=0. 0001425 sumb=0. 0001426 c 0001427 do 130 i=1,ncp1 0001428 suma=suma+zst1(it,i)*extmu(i,j) 0001429 sumb=sumb+zst2(it,i)*extmu(i,j) 0001430 130 continue 0001431 c 0001432 c multiply by m-matrix see eq(6.7) 0001433 c 0001434 tenr=ematx(1,j)*suma+ematx(2,j)*sumb 0001435 tenl=ematx(3,j)*suma 0001436 c 0001437 tensum=tenl+tenr 0001438 c write(33,565)suma,sumb,ematx(1,j),ematx(2,j),ematx(3,j),emu(j), 0001439 c 1 tenl,tenr,tensum 0001440 565 format('evalrf',9f8.5) 0001441 c 0001442 c compute istar/ig of eq (6.7) 0001443 c 0001444 c new statements added here 0001445 if(ipol.eq.0)then 0001446 tnstr(j)=c316*(tenr+tenl)/emu(j) 0001447 else 0001448 tnstr(j)=0.25d0*(q1/sdp)*(tenr+tenl)/emu(j) 0001449 endif 0001450 120 continue 0001451 c 0001452 100 continue 0001453 c 0001454 c 0001455 do 145 j=1,nalb 0001456 qr(j)=alb(j)/(1.-sb(4)*alb(j)) 0001457 145 continue 0001458 c 0001459 c 0001460 c**** store data for archive tape 0001461 c**** check if tables data set to be created 0001462 c 0001463 rarray(407)=sb(4) 0001464 j=420 0001465 do 200 i=1,ncp1 0001466 k=j+1 0001467 rarray(j)=zst1(4,i) 0001468 rarray(k)=zst2(4,i) 0001469 j=j+2 0001470 200 continue 0001471 c**** write data to tape 0001472 c 0001473 c write (34) rarray,psaray,iarray 0001474 c 0001475 c**** check if tables data set to be created 0001476 c 0001477 c**** load r*4 output buffer for later fwrite 0001478 c out48(1)=float(lambda) 0001479 c out48(2)=alfaef 0001480 c out48(3)=beta 0001481 c out48(4)=code 0001482 c out48(5)=pnot 0001483 c out48(6)=sb(4) 0001484 c j=7 0001485 c do 275 iload=1,15 0001486 c out48(j)=tnstr(iload) 0001487 c j=j+1 0001488 c 275 continue 0001489 c out48(22)=float(imuz) 0001490 c out48(23)=float(imu) 0001491 c j=24 0001492 c do 260 i=1,15 0001493 c out48(j)=thta(i) 0001494 c j=j+1 0001495 c 260 continue 0001496 c write(35) out48 0001497 c 0001498 c*****optional print out of z-star array 0001499 c 0001500 if (jprint(2) .eq. 1) then 0001501 write(33,1000) 0001502 write(33,2000) (k,(zst1(j,k),j=1,4),(zst2(j,k), j=1,4), 0001503 1 k=1,ncp1) 0001504 write(33,2500) 0001505 write(33,3000) (k,thta(k),tnstr(k),k=1,imu) 0001506 write(33,3500) sb(it) 0001507 endif 0001508 c 0001509 return 0001510 1000 format(1h1,t50,'debug printout for evalrf',///,25x, 0001511 1 'zst1(i=1,4)',47x,'zst2(i=1,4)') 0001512 2000 format(2x,i3,4e13.5,5x,4e13.5) 0001513 2500 format(///,2x,'imu',20x,'tnstr(j)') 0001514 3000 format(5x,'theta.',5x,'tnstr(k)',//,(1x,i2,3x,f6.2,2x,d12.6)) 0001515 3500 format(///,' sb=',e15.5) 0001516 end INCLUDE FILES FileNo File name 1 hedout.inc 2 tabbuf.inc 3 emm.inc 4 eks.inc 5 contrl.inc 6 consts.inc 7 out.inc 8 prints.inc 9 in.inc 10 depolt.inc ENTRY POINTS Name Type BlockNo evalrf SUBR 224 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References evalrf SUBR 1301D geopro SUBR EXTERNAL 1395 1396 COMMON BLOCKS Name Size BlockNo consts_ 112 66 contrl_ 2808 85 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 hedout_ 7260 89 in_ 196 126 out_ 3256 117 prints_ 40 124 tabbuf_ 192 178 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 3-2D 3-4D alb R*8 (11) VAR COMMON 85 200 5-3D 5-5D 1456(2) alfaef R*8 VAR COMMON 85 2792 5-5D azmth R*8 (8) VAR COMMON 85 136 5-3D 5-5D c1415 R*8 VAR COMMON 66 72 6-2D 6-4D c215 R*8 VAR COMMON 66 48 6-2D 6-4D c2815 R*8 VAR COMMON 66 80 6-2D 6-4D c316 R*8 VAR DATA 236 0 1382I 1446 c38sq2 R*8 VAR COMMON 66 64 6-2D 6-4D c815 R*8 VAR COMMON 66 56 6-2D 6-4D caz R*8 (8) VAR COMMON 105 784 3-2D 3-4D caz2 R*8 (8) VAR COMMON 105 912 3-2D 3-4D cnvrt R*8 VAR COMMON 66 8 6-2D 6-4D cons R*8 VAR COMMON 66 32 6-2D 6-4D delp R*8 VAR COMMON 70 40 10-3D 10-4D delx R*8 (10) VAR COMMON 126 0 9-2D 9-4D eiaz1 R*8 (15,8) VAR COMMON 117 360 7-2D 7-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 7-2D 7-3D eizero R*8 (15) VAR COMMON 117 240 7-2D 7-3D ek4 R*8 (202) VAR COMMON 120 24240 4-2D 4-3D 1408 ek5 R*8 (202) VAR COMMON 120 25856 4-2D 4-3D 1408 ematx R*8 (3,15) VAR COMMON 105 0 3-2D 3-4D 1434(2) 1435 emu R*8 (15) VAR COMMON 105 976 3-2D 3-4D 1446 1448 emuz R*8 (10) VAR COMMON 105 1096 3-2D 3-4D extmu R*8 (202,15) VAR COMMON 120 0 4-2D 4-3D 1428 1429 fs R*8 VAR COMMON 117 2288 7-2D 7-3D gama R*8 VAR COMMON 70 8 10-3D 10-4D gg R*8 VAR COMMON 117 2280 7-2D 7-3D hhold R*8 (101) VAR COMMON 85 1904 5-3D 5-5D i I*4 VAR AUTO 224 4 1390= 1392(2) 1393(2) 1395 1396 1398= 1407= 1408(4) 1409= 1427= 1428(2) 1429(2) 1430= 1465= 1467 1468 1470= iarray I*4 (3) VAR COMMON 89 7248 1-2D 1-4D iazmth I*4 VAR COMMON 85 12 5-2D 5-5D imu I*4 VAR COMMON 85 4 5-2D 5-5D 1423 1505 imuz I*4 VAR COMMON 85 8 5-2D 5-5D ipath I*4 VAR COMMON 126 192 9-3D 9-4D ipol I*4 VAR COMMON 70 64 10-2D 10-4D 1412 1418 1419 1445 ipsudo I*4 VAR COMMON 126 188 9-3D 9-4D it I*4 VAR AUTO 224 12 1400= 1408(2) 1413 1415 1428 1429 1506 itmax I*4 VAR COMMON 126 184 9-3D 9-4D 1391 j I*4 VAR AUTO 224 44 1423= 1428 1429 1434(2) 1435 1446(2) 1448(2) 1450= 1455= 1456(3) 1457= 1464= 1466 1467 1469(2)= 1502(4) jprint I*4 (10) VAR COMMON 124 0 8-2D 8-3D 1418 1419 1500 k I*4 VAR AUTO 224 100 1466= 1468 1502(5)= 1505(5)= kskip R*8 VAR COMMON 66 104 6-2D 6-4D lambda I*4 VAR COMMON 85 2800 5-2D 5-5D layer I*4 VAR COMMON 85 2804 5-2D 5-5D nalb I*4 VAR COMMON 85 0 5-2D 5-5D 1455 ncp1 I*4 VAR ARG 1301D 1390 1407 1427 1465 1502 numek R*8 VAR COMMON 66 96 6-2D 6-4D out48 R*4 (48) VAR COMMON 178 0 2-2D 2-3D pi R*8 VAR COMMON 66 0 6-2D 6-4D psaray R*8 (82) VAR COMMON 89 6592 1-3D 1-4D pscaleforg R*8 VAR COMMON 66 88 6-2D 6-4D pshold R*8 (101) VAR COMMON 85 1096 5-3D 5-5D q R*8 VAR COMMON 70 16 10-3D 10-4D q1 R*8 VAR COMMON 70 24 10-3D 10-4D 1448 q12s R*8 VAR COMMON 70 56 10-3D 10-4D 1415 q2 R*8 VAR COMMON 70 32 10-3D 10-4D qr R*8 (11) VAR COMMON 117 32 7-2D 7-3D 1456= r R*8 VAR COMMON 66 16 6-2D 6-4D rarray R*8 (824) VAR COMMON 89 0 1-3D 1-4D 1463= 1467= 1468= rhon R*8 VAR COMMON 70 0 10-3D 10-4D rinv R*8 VAR COMMON 66 24 6-2D 6-4D saz R*8 (8) VAR COMMON 105 720 3-2D 3-4D saz2 R*8 (8) VAR COMMON 105 848 3-2D 3-4D sb R*8 (4) VAR COMMON 117 0 7-2D 7-3D 1413= 1415= 1418(2) 1419(2) 1456 1463 1506 sdp R*8 VAR COMMON 70 48 10-3D 10-4D 1448 sq2 R*8 VAR COMMON 66 40 6-2D 6-4D sum2 R*8 VAR AUTO 224 24 1403= 1408(2)= 1413 1415 sum2l R*8 VAR AUTO 224 32 1405= sum2r R*8 VAR AUTO 224 40 1406= suma R*8 VAR AUTO 224 56 1424= 1428(2)= 1434 1435 sumb R*8 VAR AUTO 224 64 1425= 1429(2)= 1434 tenl R*8 VAR AUTO 224 88 1435= 1437 1446 1448 tenr R*8 VAR AUTO 224 80 1434= 1437 1446 1448 tenstr R*8 (4,15) VAR 1367D Variable declared and not used tensum R*8 VAR AUTO 224 96 1437= thnot R*8 (10) VAR COMMON 85 2712 5-3D 5-5D thta R*8 (15) VAR COMMON 85 16 5-3D 5-5D 1505 tmp0 R*8 VAR COMMON 126 176 9-2D 9-4D tmp10 R*8 (10) VAR COMMON 126 88 9-2D 9-4D tmptop R*8 VAR COMMON 126 168 9-2D 9-4D tnstr R*8 (15) VAR COMMON 117 120 7-2D 7-3D 1446= 1448= 1505 totint R*8 (15,8) VAR COMMON 117 2296 7-2D 7-3D x R*8 (101) VAR COMMON 85 288 5-3D 5-5D xtop R*8 VAR COMMON 126 80 9-2D 9-4D zst1 R*8 (4,202) VAR ARG 1301D 1367D 1392(2)= 1395A 1408 1428 1467 1502 zst2 R*8 (4,202) VAR ARG 1301D 1367D 1393(2)= 1396A 1408 1429 1468 1502 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 1452 120 1450 145 1457 200 1470 501 1420 1000 1510 2500 1513 3500 1515 110 1409 130 1430 160 1398 500 1385 565 1440 2000 1512 3000 1514 0001517 subroutine expone (nc,ncp1,imu) 0001518 c 0001519 c*********************************************************************** 0001520 cccc 0001521 c subroutine expone 0001522 c version aug 18,1977 0001523 c 0001524 c purpose 0001525 c 0001526 c expone is a fortran 4 routine to calulate the iteration 0001527 c integrals of eq 4.11 and k functions of eq 4.6 0001528 c 0001529 c method 0001530 c kernals of intgrals to be used in reflex and iterate 0001531 c are calulated and stored on a disk file 0001532 c 0001533 c calling sequence 0001534 c call expone (ncp,ncp1) 0001535 c 0001536 c variable type i/o description 0001537 c -------- ---- --- ------------ 0001538 c 0001539 c nc i*4 i # of layers from top of 0001540 c atmosphere to reflecting surface 0001541 c ncp1 i*4 o nc+1 0001542 c 0001543 c external references 0001544 c dexpk1 0001545 c 0001546 c common areas referenced 0001547 c consts 0001548 c eks 0001549 c emm 0001550 c es 0001551 c prints 0001552 c thkns 0001553 c 0001554 c analysis and programming k.f. klenk sasc aug 18,1977 0001555 c 0001556 c modifications (date , name, purpose) 0001557 c 0001558 c last modified 03/14/95...dave flittner 0001559 c purpose: set pressure scale height used in gravity correction 0001560 c to rayleigh scattering od. Create new variable pscaleforg and 0001561 c pass in common block consts. 0001562 c 0001563 cccc 0001564 c*********************************************************************** 0001565 c 0001566 implicit integer*4(i-n),real*8(a-h,o-z) 0001567 real*8 ekary(202,5),extmux(202,15) 0001568 c 0001569 include "prints.inc" 0001570 include "nek.inc" 0001571 include "emm.inc" 0001572 include "eks.inc" 0001573 include "thkns.inc" 0001574 include "consts.inc" 0001575 include "es.inc" 0001576 c 0001577 c new statement 0001578 include "depolt.inc" 0001579 c end of new statement 0001580 c 0001581 do 75 i=1,ncp1 0001582 c initialize ekary 0001583 do 200 j=1,5 0001584 ekary(i,j)=0.d0 0001585 200 continue 0001586 c 0001587 c calculate w(t)dt*attenuation factor (see eqn. 3.6,6.7) 0001588 c 0001589 do 205 j=1,imu 0001590 extmu(i,j)=dtsp(i)*dexp(-tt(i)/emu(j)) 0001591 extmux(i,j)=extmu(i,j)/emu(j) 0001592 205 continue 0001593 if (i.eq.1) go to 55 0001594 im1=i-1 0001595 c 0001596 do 210 j=1,5 0001597 ekary(im1,j)=0. 0001598 210 continue 0001599 c 0001600 if(i.eq.2) go to 50 0001601 im2=i-2 0001602 c 0001603 c calculates the elements of k1 matrix (see eqn 4.11) 0001604 c evaluate k1(1),k1(2) of eqn 4.7 for current value of 0001605 c argument (tt(i)-tt(j)) 0001606 c 0001607 do 45 j=1,im2 0001608 call dexpk(tt(i),tt(j)) 0001609 c 0001610 c ekary array contains k matrix*w(t)dt 0001611 c 0001612 do 220 jk=1,5 0001613 ekary(j,jk)=dtsp(j)*eek(jk) 0001614 220 continue 0001615 if(i.lt.ncp1) go to 45 0001616 c new statements 0001617 if(ipol.eq.0)then 0001618 ek4(j)=(e(2)+e(4))*dtsp(j) 0001619 ek5(j)=sq2*(e(2)-e(4))*dtsp(j) 0001620 else 0001621 ek4(j)=((1.0d0+2.0d0*q)*e(2)+e(4))*dtsp(j) 0001622 ek5(j)=delp*(e(2)-e(4))*dtsp(j) 0001623 endif 0001624 c end of new statements 0001625 45 continue 0001626 c 0001627 call dexpk(tt(i),tt(im1)) 0001628 do 230 k=1,5 0001629 ekary(im1,k)=dtts(im1)*eek(k) 0001630 230 continue 0001631 c 0001632 if(i.lt.ncp1) go to 50 0001633 c new statements 0001634 if(ipol.eq.0)then 0001635 ek4(nc)=dtsp(nc)*(e(2)+e(4)) 0001636 ek5(nc)=sq2*dtsp(nc)*(e(2)-e(4)) 0001637 else 0001638 ek4(nc)=((1.0d0+2.0d0*q)*e(2)+e(4))*dtsp(nc) 0001639 ek5(nc)=delp*(e(2)-e(4))*dtsp(nc) 0001640 endif 0001641 c end of new statements 0001642 50 call dexpk1(tt(i),tt(im1)) 0001643 c 0001644 do 240 k=1,5 0001645 ekary(im1,k)=ekary(im1,k)+dtts(i)*eek(k) 0001646 240 continue 0001647 c 0001648 do 250 k=1,5 0001649 ekary(i,k)=dtts(i)*eek(k) 0001650 250 continue 0001651 if(i.lt.ncp1) go to 55 0001652 c new statemnets 0001653 if(ipol.eq.0)then 0001654 ek4(ncp1)=dtsp(ncp1)*(odan(2)+odan(4)) 0001655 ek5(ncp1)=sq2*dtsp(ncp1)*(odan(2)-odan(4)) 0001656 else 0001657 ek4(ncp1)=((1.0d0+2.0d0*q)*odan(2)+odan(4))*dtsp(ncp1) 0001658 ek5(ncp1)=delp*(odan(2)-odan(4))*dtsp(ncp1) 0001659 endif 0001660 c end of new statements 0001661 go to 65 0001662 55 ip1=i+1 0001663 call dexpk1(tt(i),tt(ip1)) 0001664 c 0001665 do 260 k=1,5 0001666 ekary(i,k)=ekary(i,k)+dtts(ip1)*eek(k) 0001667 260 continue 0001668 c 0001669 do 270 k=1,5 0001670 ekary(ip1,k)=dtts(ip1)*eek(k) 0001671 270 continue 0001672 c 0001673 if(i.eq.nc) go to 65 0001674 ip2=i+2 0001675 call dexpk(tt(i),tt(ip1)) 0001676 c 0001677 do 280 k=1,5 0001678 ekary(ip1,k)=ekary(ip1,k)+dtts(ip2)*eek(k) 0001679 280 continue 0001680 c 0001681 do 60 j=ip2,ncp1 0001682 call dexpk(tt(i),tt(j)) 0001683 c 0001684 do 290 k=1,5 0001685 ekary(j,k)=dtsp(j)*eek(k) 0001686 290 continue 0001687 60 continue 0001688 c 0001689 c 0001690 65 continue 0001691 do 5000 ii = 1,202 0001692 do 5001 iii = 1,5 0001693 nek(ii,iii,i) = ekary(ii,iii) 0001694 5001 continue 0001695 5000 continue 0001696 75 continue 0001697 c 0001698 c optionally print calculated exponential terms 0001699 c (zstar matrix * w(t)dt see eqn 6.3) 0001700 c 0001701 if (jprint(3).ne.0) then 0001702 write (33,6120) (j,ek4(j),ek5(j) ,j=1,ncp1) 0001703 do 295 i=1,imu 0001704 thta=dacos(emu(i))/cnvrt 0001705 write(33,7120) thta,(j,extmux(j,i),j=1,ncp1,10) 0001706 write(33,7130) ncp1,extmux(ncp1,i) 0001707 295 continue 0001708 endif 0001709 return 0001710 6120 format(1h1,t50,'debug print out for expone',///, 0001711 1 1h ,2(' j',4x,'ek4(j)',6x,'ek5(j)',6x),//,2(1x,i3,2d12.4,3x)) 0001712 7120 format(1x,//,1x,'theta=',f6.2,' *** attenuation factors/*** ',//, 0001713 1 1x,'level',5x,'extmu/mu',/,(1x,i5,3x,d12.6)) 0001714 7130 format(1x,i5,3x,d12.6) 0001715 end INCLUDE FILES FileNo File name 1 prints.inc 2 nek.inc 3 emm.inc 4 eks.inc 5 thkns.inc 6 consts.inc 7 es.inc 8 depolt.inc ENTRY POINTS Name Type BlockNo expone SUBR 260 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dacos INTRINSIC 1704 dexp INTRINSIC 1590 dexpk SUBR EXTERNAL 1608 1627 1675 1682 dexpk1 SUBR EXTERNAL 1642 1663 expone SUBR 1517D COMMON BLOCKS Name Size BlockNo consts_ 112 66 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 es_ 144 68 kmat_ 1632160 263 prints_ 40 124 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 3-2D 3-4D c1415 R*8 VAR COMMON 66 72 6-2D 6-4D c215 R*8 VAR COMMON 66 48 6-2D 6-4D c2815 R*8 VAR COMMON 66 80 6-2D 6-4D c38sq2 R*8 VAR COMMON 66 64 6-2D 6-4D c815 R*8 VAR COMMON 66 56 6-2D 6-4D caz R*8 (8) VAR COMMON 105 784 3-2D 3-4D caz2 R*8 (8) VAR COMMON 105 912 3-2D 3-4D cnvrt R*8 VAR COMMON 66 8 6-2D 6-4D 1704 cons R*8 VAR COMMON 66 32 6-2D 6-4D delp R*8 VAR COMMON 70 40 8-3D 8-4D 1622 1639 1658 dtsp R*8 (202) VAR COMMON 83 5656 5-2D 5-3D 1590 1613 1618 1619 1621 1622 1635 1636 1638 1639 1654 1655 1657 1658 1685 dtts R*8 (202) VAR COMMON 83 7272 5-2D 5-3D 1629 1645 1649 1666 1670 1678 e R*8 (6) VAR COMMON 68 48 7-2D 7-3D 1618(2) 1619(2) 1621(2) 1622(2) 1635(2) 1636(2) 1638(2) 1639(2) eek R*8 (6) VAR COMMON 68 96 7-2D 7-3D 1613 1629 1645 1649 1666 1670 1678 1685 ek4 R*8 (202) VAR COMMON 120 24240 4-2D 4-3D 1618= 1621= 1635= 1638= 1654= 1657= 1702 ek5 R*8 (202) VAR COMMON 120 25856 4-2D 4-3D 1619= 1622= 1636= 1639= 1655= 1658= 1702 ekary R*8 (202,5) VAR AUTO 260 8096 1567D 1584= 1597= 1613= 1629= 1645(2)= 1649= 1666(2)= 1670= 1678(2)= 1685= 1693 ematx R*8 (3,15) VAR COMMON 105 0 3-2D 3-4D emu R*8 (15) VAR COMMON 105 976 3-2D 3-4D 1590 1591 1704A emuz R*8 (10) VAR COMMON 105 1096 3-2D 3-4D extmu R*8 (202,15) VAR COMMON 120 0 4-2D 4-3D 1590= 1591 extmux R*8 (202,15) VAR AUTO 260 32352 1567D 1591= 1705 1706 gama R*8 VAR COMMON 70 8 8-3D 8-4D i I*4 VAR AUTO 260 4 1581= 1584 1590(3) 1591(2) 1593 1594 1600 1601 1608 1615 1627 1632 1642 1645 1649(2) 1651 1662 1663 1666(2) 1673 1674 1675 1682 1693 1696= 1703= 1704 1705 1706 1707= ii I*4 VAR AUTO 260 32380 1691= 1693(2) 1695= iii I*4 VAR AUTO 260 32384 1692= 1693(2) 1694= im1 I*4 VAR AUTO 260 32356 1594= 1597 1627 1629(2) 1642 1645(2) im2 I*4 VAR AUTO 260 32360 1601= 1607 imu I*4 VAR ARG 1517D 1589 1703 ip1 I*4 VAR AUTO 260 32372 1662= 1663 1666 1670(2) 1675 1678(2) ip2 I*4 VAR AUTO 260 32376 1674= 1678 1681 ipol I*4 VAR COMMON 70 64 8-2D 8-4D 1617 1634 1653 j I*4 VAR AUTO 260 12 1583= 1584 1585= 1589= 1590(2) 1591(3) 1592= 1596= 1597 1598= 1607= 1608 1613(2) 1618(2) 1619(2) 1621(2) 1622(2) 1625= 1681= 1682 1685(2) 1687= 1702(5)= 1705(4)= jk I*4 VAR AUTO 260 32364 1612= 1613(2) 1614= jprint I*4 (10) VAR COMMON 124 0 1-2D 1-3D 1701 k I*4 VAR AUTO 260 32368 1628= 1629(2) 1630= 1644= 1645(3) 1646= 1648= 1649(2) 1650= 1665= 1666(3) 1667= 1669= 1670(2) 1671= 1677= 1678(3) 1679= 1684= 1685(2) 1686= kskip R*8 VAR COMMON 66 104 6-2D 6-4D nc I*4 VAR ARG 1517D 1635(2) 1636(2) 1638(2) 1639(2) 1673 ncp1 I*4 VAR ARG 1517D 1581 1615 1632 1651 1654(2) 1655(2) 1657(2) 1658(2) 1681 1702 1705 1706(2) nek R*8 (202,5,202) VAR COMMON 263 0 2-2D 2-3D 1693= numek R*8 VAR COMMON 66 96 6-2D 6-4D odan R*8 (6) VAR COMMON 68 0 7-2D 7-3D 1654(2) 1655(2) 1657(2) 1658(2) pi R*8 VAR COMMON 66 0 6-2D 6-4D pscaleforg R*8 VAR COMMON 66 88 6-2D 6-4D q R*8 VAR COMMON 70 16 8-3D 8-4D 1621 1638 1657 q1 R*8 VAR COMMON 70 24 8-3D 8-4D q12s R*8 VAR COMMON 70 56 8-3D 8-4D q2 R*8 VAR COMMON 70 32 8-3D 8-4D r R*8 VAR COMMON 66 16 6-2D 6-4D rhon R*8 VAR COMMON 70 0 8-3D 8-4D rinv R*8 VAR COMMON 66 24 6-2D 6-4D saz R*8 (8) VAR COMMON 105 720 3-2D 3-4D saz2 R*8 (8) VAR COMMON 105 848 3-2D 3-4D sdp R*8 VAR COMMON 70 48 8-3D 8-4D sq2 R*8 VAR COMMON 66 40 6-2D 6-4D 1619 1636 1655 thta R*8 VAR AUTO 260 32392 1704= 1705 tsl R*8 (101) VAR COMMON 83 0 5-2D 5-3D tt R*8 (202) VAR COMMON 83 808 5-2D 5-3D 1590 1608(2)A 1627(2)A 1642(2)A 1663(2)A 1675(2)A 1682(2)A ttl R*8 (202) VAR COMMON 83 4040 5-2D 5-3D tts R*8 (202) VAR COMMON 83 2424 5-2D 5-3D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 45 1625 60 1687 200 1585 220 1614 250 1650 280 1679 5000 1695 7120 1712 50 1642 65 1690 205 1592 230 1630 260 1667 290 1686 5001 1694 7130 1714 55 1662 75 1696 210 1598 240 1646 270 1671 295 1707 6120 1710 0001716 subroutine exponesph(h,ps,cofx,lmax,nc,ncp1,imu) 0001717 c 0001718 c*********************************************************************** 0001719 cccc 0001720 c subroutine exponesph 0001721 c 0001722 c purpose- 0001723 c 1. calculate the slant path scattering and total optical depths 0001724 c for a particular line of sight. This is used in the 0001725 c integration of the output beam. 0001726 c 2. Then calculate the trapezoidal integration factors using the 0001727 c calculated slant path optical depths. 0001728 c 0001729 c 3. calculate the iteration integration factors for a flat 0001730 c atmosphere for eq. 4.11 and k functions of eq 4.6. 0001731 c This is done the same way as in routine expone. 0001732 c 0001733 c method- 0001734 c 1. using the fine layer scattering and total optical depths in 0001735 c ps and dxs, and the altitude of the layer boundaries, h, 0001736 c use simple spherical trig. to calc. the ratio of the distance 0001737 c through a layer in a spherical atmosphere to that in a flat 0001738 c atmosphere. The result is stored in the arrays ttsf_sph and 0001739 c ttf_sph. 0001740 c 2. The integration factors are computed using extmu=layer scattering 0001741 c optical thickness * transmission to from level to top of atmo. 0001742 c Integral = 0.5*Source(1)*Transmission(1)* 0001743 c scattering optical thickness of layer 1 + 0001744 c Sum from i=2 to nc of 0.5*(Source(i)*Transmission(i) 0001745 c +Source(i+1)*Transmission(i+1))* 0001746 c scattering optical thickness of layer i + 0001747 c 0.5*Source(ncp1)*Transmission(ncp1) 0001748 c scattering optical thickness of layer ncp1 0001749 c 3. If the scan angle is equal to 0.0 degrees, then the quantities 0001750 c are computed quickly using a flat atmosphere. Again, note 0001751 c that the integration factors used in the iteration process 0001752 c are for a flat atmosphere. Only the final integration of the 0001753 c out-going beam is done in a spherical atmosphere. 0001754 c 0001755 c calling sequence- 0001756 c call exponesph(h,ps,cofx,lmax,nc,ncp1,imu) 0001757 c 0001758 c variable type i/o description 0001759 c -------- ---- --- ----------- 0001760 c 0001761 c h(487) r*8 i height from earth center(fraction of r) 0001762 c ps(487) r*8 i rayleigh opt. thickness of each layer 0001763 c of the standard atmosphere 0001764 c cofx(4,487) r*8 i spline interpolation coeff. 0001765 c lmax i*4 i number of layers in the standard atmosphere 0001766 c nc i*4 i # of layers from top of 0001767 c atmosphere to reflecting surface 0001768 c ncp1 i*4 i nc+1 0001769 c imu i*4 i # of scan angles 0001770 c passed through common blocks 0001771 c dxs(487) r*8 i total opt. thickness of each layer 0001772 c of the standard atmosphere 0001773 c xs(487) r*8 i log of the total opt. depth to a level 0001774 c of the standard atmosphere 0001775 c ttl(202) r*8 i log of the total vertical optical depth 0001776 c emu(15) r*8 i cosine of the scan angle 0001777 c extmu(202,15) r*8 o trapezoidal integration factor for each level 0001778 c 0001779 c internal arrays of note 0001780 c dtsp_sph(202) r*8 avg. scattering optical thickness of each 0001781 c spherical layer 0001782 c dtts_sph(202) r*8 avg. scattering optical thickness of each 0001783 c spherical half layer at mid points between 0001784 c layers 0001785 c transph(202) r*8 transmission from level to the top of the 0001786 c spherical atmosphere 0001787 c 0001788 c external references 0001789 c dexpk1 (subroutine) 0001790 c omerf (function) 0001791 c 0001792 c common areas referenced 0001793 c consts 0001794 c eks 0001795 c emm 0001796 c es 0001797 c prints 0001798 c thkns 0001799 c chpmn 0001800 c csphout 0001801 c kmat 0001802 c crefdir 0001803 c depolt 0001804 c 0001805 c last modified 03/14/95...dave flittner 0001806 c purpose: set pressure scale height used in gravity correction 0001807 c to rayleigh scattering od. Create new variable pscaleforg and 0001808 c pass in common block consts. 0001809 c*********************************************************************** 0001810 cccc 0001811 implicit none 0001812 c input 0001813 integer*4 lmax,nc,ncp1,imu 0001814 real*8 h(487),ps(487),cofx(4,487) 0001815 c internal 0001816 integer*4 i,j,lmaxm1,im,im1,im2,jk,k,ip1,ip2,ii,iii 0001817 real*8 sintheta,pc,pcpc,dist1,dist2,ddist,ratio,dum1,dum2,dum3 0001818 real*8 ttsf_sph(487),ttf_sph(487) 0001819 real*8 tts_sph(202) 0001820 real*8 dtts_sph(202),dtsp_sph(202),transph(202) 0001821 real*8 chpp,chxx,thta,sum,thetap 0001822 real*8 ekary(202,5),extmux(202,15) 0001823 c 0001824 c common block area 0001825 c 0001826 include "chpmn.inc" 0001827 include "thkns.inc" 0001828 include "csphout.inc" 0001829 include "prints.inc" 0001830 include "emm.inc" 0001831 include "kmat.inc" 0001832 include "eks.inc" 0001833 include "consts.inc" 0001834 include "es.inc" 0001835 include "crefdir.inc" 0001836 c 0001837 c new statement 0001838 include "depolt.inc" 0001839 c end of new statement 0001840 c 0001841 c external functions used 0001842 real*8 omerf 0001843 external omerf 0001844 c end of portion lifted from expone ! def 0001845 c 0001846 c loop for each scan angle 0001847 c 0001848 do 199 im=1,imu 0001849 c now loop using the simple trig. relations 0001850 c calc. the tangent height in terms of earth radii using the scan angle 0001851 c at the surface 0001852 sintheta=(1.0d0-emu(im)*emu(im)) 0001853 if(sintheta.le.0.0d0)then 0001854 c do not need to correct, for sphericity, so will use the flat atmo. case 0001855 do i=1,ncp1 0001856 extmu(i,im)=dtsp(i)*dexp(-tt(i)) 0001857 enddo 0001858 refdir(im)=dexp(-tt(ncp1)) 0001859 goto 199 0001860 else if(sintheta.gt.1.0d0)then 0001861 sintheta=1.0d0 0001862 pc=h(lmax) 0001863 else 0001864 sintheta=dsqrt(sintheta) 0001865 pc=h(lmax)*sintheta 0001866 endif 0001867 c start at top of atmosphere and work way down along the line of sight 0001868 c use chapman function to do the first layer which ranges from h(1) to 0001869 c infinity. Note that the approximation used to evaluate the Chapman 0001870 c function for dum1=1.0 (scan angle of 0.0 deg.) returns a value less 0001871 c than that in a flat atmosphere. 0001872 dum1=pc/h(1) 0001873 dum1=dsqrt(1.0d0-dum1**2) 0001874 chpp=omerf(sqchp*dum1,dum1,chpn) 0001875 chxx=omerf(sqchx*dum1,dum1,chxn) 0001876 ttsf_sph(1)=ps(1)*chpp 0001877 ttf_sph(1)=(dxs(1)-ps(1))*chxx+ps(1)*chpp 0001878 c now start the loop to create the fine arrays 0001879 pcpc=pc*pc 0001880 dist1=dsqrt(h(1)*h(1)-pcpc) 0001881 do i=2,lmax 0001882 dist2=dsqrt(h(i)*h(i)-pcpc) 0001883 ddist=dist1-dist2 0001884 ratio=ddist/(h(i-1)-h(i)) 0001885 ttsf_sph(i)=ttsf_sph(i-1)+ps(i)*ratio 0001886 ttf_sph(i)=ttf_sph(i-1)+dxs(i)*ratio 0001887 dist1=dist2 0001888 enddo 0001889 sum=0.0d0 0001890 c now spline log of slant total od. as a function of the log of veritcal od. 0001891 do i=1,lmax 0001892 ttf_sph(i)=log(ttf_sph(i)) 0001893 enddo 0001894 call splset(xs,ttf_sph,cofx,lmax) 0001895 c 0001896 c*****for each layer of model atmosphere find two layers in the 0001897 c*****standard atmosphere straddling it and find total slant optical 0001898 c*****path to reach each layer of model atmosphere- 0001899 c*****using spline interpolation and then compute the slant tranmission 0001900 c*****and store in transph 0001901 c 0001902 transph(1) = 1.0 0001903 j = 2 0001904 lmaxm1 = lmax - 1 0001905 do 110 i = 1, lmaxm1 0001906 if (ttl(j) .le. xs(i) .or. ttl(j) .gt. xs(i+1)) go to 110 0001907 100 dum1 = xs(i+1) - ttl(j) 0001908 dum2 = ttl(j) - xs(i) 0001909 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0001910 1 dum2**2 + cofx(4,i)) 0001911 dum3 = dexp(dum3) 0001912 transph(j) = dexp(-dum3) 0001913 j = j + 1 0001914 if (j .gt. ncp1) go to 120 0001915 if (ttl(j) .gt. xs(i) .and. ttl(j) .le. xs(i+1)) go to 100 0001916 110 continue 0001917 c 0001918 c*****find values for the bottom layer by extrapolation if it was not 0001919 c*****obtained during the above interpolation 0001920 c 0001921 120 if (ttl(ncp1) .le. xs(lmax)) go to 125 0001922 dum1 = xs(lmax) - ttl(ncp1) 0001923 dum2 = ttl(ncp1) - xs(lmaxm1) 0001924 i = lmaxm1 0001925 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0001926 1 dum2**2 + cofx(4,i)) 0001927 dum3 = dexp(dum3) 0001928 transph(ncp1) = dexp(-dum3) 0001929 125 continue 0001930 refdir(im)=transph(ncp1) 0001931 c 0001932 c now need to calculate the spherical scattering optical thickness of 0001933 c each layer. Already have the scattering optical depth along the slant path, 0001934 c so can use a spline of log(tts_sph) versus xs and interpolate to the 0001935 c points ttl and use the same method to compute the average scattering 0001936 c optical thickness of each layer as is done in dtaus 0001937 do i=1,lmax 0001938 ttsf_sph(i)=log(ttsf_sph(i)) 0001939 enddo 0001940 call splset(xs,ttsf_sph,cofx,lmax) 0001941 c now interpolate to ttl to get slant scattering od. 0001942 c 0001943 c*****for each layer of model atmosphere find two layers in the 0001944 c*****standard atmosphere straddling it and find slant scattering optical 0001945 c*****path to reach each layer of model atmosphere- 0001946 c*****using spline interpolation and store in tts_sph 0001947 c 0001948 tts_sph(1) = 0.0 0001949 j = 2 0001950 lmaxm1 = lmax - 1 0001951 do 140 i = 1, lmaxm1 0001952 if (ttl(j) .le. xs(i) .or. ttl(j) .gt. xs(i+1)) go to 140 0001953 130 dum1 = xs(i+1) - ttl(j) 0001954 dum2 = ttl(j) - xs(i) 0001955 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0001956 1 dum2**2 + cofx(4,i)) 0001957 dum3 = dexp(dum3) 0001958 tts_sph(j) = dum3 0001959 j = j + 1 0001960 if (j .gt. ncp1) go to 150 0001961 if (ttl(j) .gt. xs(i) .and. ttl(j) .le. xs(i+1)) go to 130 0001962 140 continue 0001963 c 0001964 c*****find values for the bottom layer by extrapolation if it was not 0001965 c*****obtained during the above interpolation 0001966 c 0001967 150 if (ttl(ncp1) .le. xs(lmax)) go to 155 0001968 dum1 = xs(lmax) - ttl(ncp1) 0001969 dum2 = ttl(ncp1) - xs(lmaxm1) 0001970 i = lmaxm1 0001971 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0001972 1 dum2**2 + cofx(4,i)) 0001973 dum3 = dexp(dum3) 0001974 tts_sph(ncp1) = dum3 0001975 155 continue 0001976 c 0001977 c now calc. dtts_sph and dtsp_sph 0001978 c 0001979 dtts_sph(1) = 0.5*tts_sph(2) 0001980 dtsp_sph(1) = 0.5*tts_sph(2) 0001981 do i=2,nc 0001982 dtsp_sph(i) = 0.5*(tts_sph(i+1) - tts_sph(i-1)) 0001983 dtts_sph(i) = 0.5*(tts_sph(i) - tts_sph(i-1)) 0001984 enddo 0001985 dtts_sph(ncp1) = 0.5*(tts_sph(ncp1)-tts_sph(nc)) 0001986 dtsp_sph(ncp1) = dtts_sph(ncp1) 0001987 c 0001988 c now calc. the integration factors 0001989 c 0001990 dum1=emu(im) 0001991 do i=1,ncp1 0001992 extmu(i,im)=dtsp_sph(i)*transph(i)*dum1 0001993 enddo 0001994 199 continue 0001995 c 0001996 c portion lifted from expone !def 0001997 c 0001998 do 400 i=1,ncp1 0001999 c initialize ekary 0002000 do 200 j=1,5 0002001 ekary(i,j)=0.d0 0002002 200 continue 0002003 c 0002004 c calculate w(t)dt*attenuation factor (see eqn. 3.6,6.7) 0002005 c 0002006 do 205 j=1,imu 0002007 extmux(i,j)=extmu(i,j)/emu(j) !def 0002008 205 continue 0002009 if (i.eq.1) go to 255 0002010 im1=i-1 0002011 c 0002012 do 210 j=1,5 0002013 ekary(im1,j)=0. 0002014 210 continue 0002015 c 0002016 if(i.eq.2) go to 235 0002017 im2=i-2 0002018 c 0002019 c calculates the elements of k1 matrix (see eqn 4.11) 0002020 c evaluate k1(1),k1(2) of eqn 4.7 for current value of 0002021 c argument (tt(i)-tt(j)) 0002022 c 0002023 do 225 j=1,im2 0002024 call dexpk(tt(i),tt(j)) 0002025 c 0002026 c ekary array contains k matrix*w(t)dt 0002027 c 0002028 do 220 jk=1,5 0002029 ekary(j,jk)=dtsp(j)*eek(jk) 0002030 220 continue 0002031 if(i.lt.ncp1) go to 225 0002032 c new statements 0002033 if(ipol.eq.0)then 0002034 ek4(j)=(e(2)+e(4))*dtsp(j) 0002035 ek5(j)=sq2*(e(2)-e(4))*dtsp(j) 0002036 else 0002037 ek4(j)=((1.0d0+2.0d0*q)*e(2)+e(4))*dtsp(j) 0002038 ek5(j)=delp*(e(2)-e(4))*dtsp(j) 0002039 endif 0002040 c end of new statements 0002041 225 continue 0002042 c 0002043 call dexpk(tt(i),tt(im1)) 0002044 do 230 k=1,5 0002045 ekary(im1,k)=dtts(im1)*eek(k) 0002046 230 continue 0002047 c 0002048 if(i.lt.ncp1) go to 235 0002049 c new statements 0002050 if(ipol.eq.0)then 0002051 ek4(nc)=dtsp(nc)*(e(2)+e(4)) 0002052 ek5(nc)=sq2*dtsp(nc)*(e(2)-e(4)) 0002053 else 0002054 ek4(nc)=((1.0d0+2.0d0*q)*e(2)+e(4))*dtsp(nc) 0002055 ek5(nc)=delp*(e(2)-e(4))*dtsp(nc) 0002056 endif 0002057 c end of new statements 0002058 235 call dexpk1(tt(i),tt(im1)) 0002059 c 0002060 do 240 k=1,5 0002061 ekary(im1,k)=ekary(im1,k)+dtts(i)*eek(k) 0002062 240 continue 0002063 c 0002064 do 250 k=1,5 0002065 ekary(i,k)=dtts(i)*eek(k) 0002066 250 continue 0002067 if(i.lt.ncp1) go to 255 0002068 c new statemnets 0002069 if(ipol.eq.0)then 0002070 ek4(ncp1)=dtsp(ncp1)*(odan(2)+odan(4)) 0002071 ek5(ncp1)=sq2*dtsp(ncp1)*(odan(2)-odan(4)) 0002072 else 0002073 ek4(ncp1)=((1.0d0+2.0d0*q)*odan(2)+odan(4))*dtsp(ncp1) 0002074 ek5(ncp1)=delp*(odan(2)-odan(4))*dtsp(ncp1) 0002075 endif 0002076 c end of new statements 0002077 go to 300 0002078 255 ip1=i+1 0002079 call dexpk1(tt(i),tt(ip1)) 0002080 c 0002081 do 260 k=1,5 0002082 ekary(i,k)=ekary(i,k)+dtts(ip1)*eek(k) 0002083 260 continue 0002084 c 0002085 do 270 k=1,5 0002086 ekary(ip1,k)=dtts(ip1)*eek(k) 0002087 270 continue 0002088 c 0002089 if(i.eq.nc) go to 300 0002090 ip2=i+2 0002091 call dexpk(tt(i),tt(ip1)) 0002092 c 0002093 do 280 k=1,5 0002094 ekary(ip1,k)=ekary(ip1,k)+dtts(ip2)*eek(k) 0002095 280 continue 0002096 c 0002097 do 295 j=ip2,ncp1 0002098 call dexpk(tt(i),tt(j)) 0002099 c 0002100 do 290 k=1,5 0002101 ekary(j,k)=dtsp(j)*eek(k) 0002102 290 continue 0002103 295 continue 0002104 c 0002105 c 0002106 300 continue 0002107 do 320 ii = 1,202 0002108 do 310 iii = 1,5 0002109 nek(ii,iii,i) = ekary(ii,iii) 0002110 310 continue 0002111 320 continue 0002112 400 continue 0002113 c 0002114 c optionally print calculated exponential terms 0002115 c (zstar matrix * w(t)dt see eqn 6.3) 0002116 c 0002117 if (jprint(3).ne.0) then 0002118 write (33,6120) (j,ek4(j),ek5(j) ,j=1,ncp1) 0002119 do 495 i=1,imu 0002120 thta=dacos(emu(i))/cnvrt 0002121 write(33,7120) thta,(j,extmux(j,i),j=1,ncp1,10) 0002122 write(33,7130) ncp1,extmux(ncp1,i) 0002123 495 continue 0002124 endif 0002125 return 0002126 6120 format(1h1,t50,'debug print out for expone',///, 0002127 1 1h ,2(' j',4x,'ek4(j)',6x,'ek5(j)',6x),//,2(1x,i3,2d12.4,3x)) 0002128 7120 format(1x,//,1x,'theta=',f6.2,' *** attenuation factors/*** ',//, 0002129 1 1x,'level',5x,'extmu/mu',/,(1x,i5,3x,d12.6)) 0002130 7130 format(1x,i5,3x,d12.6) 0002131 c end of portion lifted from expone.f !def 0002132 end INCLUDE FILES FileNo File name 1 chpmn.inc 2 thkns.inc 3 csphout.inc 4 prints.inc 5 emm.inc 6 kmat.inc 7 eks.inc 8 consts.inc 9 es.inc 10 crefdir.inc 11 depolt.inc ENTRY POINTS Name Type BlockNo exponesph SUBR 298 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dacos INTRINSIC 2120 dexp INTRINSIC 1856 1858 1911 1912 1927 1928 1957 1973 dexpk SUBR EXTERNAL 2024 2043 2091 2098 dexpk1 SUBR EXTERNAL 2058 2079 dsqrt INTRINSIC 1864 1873 1880 1882 exponesph SUBR 1716D log INTRINSIC 1892 1938 omerf R*8 EXTERNAL 1842D 1843D 1874 1875 splset SUBR EXTERNAL 1894 1940 COMMON BLOCKS Name Size BlockNo chpmn_ 7824 300 consts_ 112 66 crefdir_ 120 311 csphout_ 4 303 depolt_ 68 70 eks_ 27472 120 emm_ 1176 105 es_ 144 68 kmat_ 1632160 263 prints_ 40 124 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 5-2D 5-4D c1415 R*8 VAR COMMON 66 72 8-2D 8-4D c215 R*8 VAR COMMON 66 48 8-2D 8-4D c2815 R*8 VAR COMMON 66 80 8-2D 8-4D c38sq2 R*8 VAR COMMON 66 64 8-2D 8-4D c815 R*8 VAR COMMON 66 56 8-2D 8-4D caz R*8 (8) VAR COMMON 105 784 5-2D 5-4D caz2 R*8 (8) VAR COMMON 105 912 5-2D 5-4D chpn R*8 VAR COMMON 300 0 1-2D 1-3D 1874A chpp R*8 VAR AUTO 298 64 1821D 1874= 1876 1877 chxn R*8 VAR COMMON 300 8 1-2D 1-3D 1875A chxx R*8 VAR AUTO 298 72 1821D 1875= 1877 cnvrt R*8 VAR COMMON 66 8 8-2D 8-4D 2120 cofx R*8 (4,487) VAR ARG 1716D 1814D 1894A 1909(4) 1925(4) 1940A 1955(4) 1971(4) cons R*8 VAR COMMON 66 32 8-2D 8-4D ddist R*8 VAR AUTO 298 7896 1817D 1883= 1884 delp R*8 VAR COMMON 70 40 11-3D 11-4D 2038 2055 2074 dist1 R*8 VAR AUTO 298 7880 1817D 1880= 1883 1887= dist2 R*8 VAR AUTO 298 7888 1817D 1882= 1883 1887 dtsp R*8 (202) VAR COMMON 83 5656 2-2D 2-3D 1856 2029 2034 2035 2037 2038 2051 2052 2054 2055 2070 2071 2073 2074 2101 dtsp_sph R*8 (202) VAR AUTO 298 14408 1820D 1980= 1982= 1986= 1992 dtts R*8 (202) VAR COMMON 83 7272 2-2D 2-3D 2045 2061 2065 2082 2086 2094 dtts_sph R*8 (202) VAR AUTO 298 12792 1820D 1979= 1983= 1985= 1986 dum1 R*8 VAR AUTO 298 48 1817D 1872= 1873(2)= 1874(2)A 1875(2)A 1907= 1909(2) 1922= 1925(2) 1953= 1955(2) 1968= 1971(2) 1990= 1992 dum2 R*8 VAR AUTO 298 9544 1817D 1908= 1909(2) 1923= 1925(2) 1954= 1955(2) 1969= 1971(2) dum3 R*8 VAR AUTO 298 9552 1817D 1909= 1911(2)= 1912 1925= 1927(2)= 1928 1955= 1957(2)= 1958 1971= 1973(2)= 1974 dxs R*8 (487) VAR COMMON 300 3928 1-2D 1-3D 1877 1886 e R*8 (6) VAR COMMON 68 48 9-2D 9-3D 2034(2) 2035(2) 2037(2) 2038(2) 2051(2) 2052(2) 2054(2) 2055(2) eek R*8 (6) VAR COMMON 68 96 9-2D 9-3D 2029 2045 2061 2065 2082 2086 2094 2101 ek4 R*8 (202) VAR COMMON 120 24240 7-2D 7-3D 2034= 2037= 2051= 2054= 2070= 2073= 2118 ek5 R*8 (202) VAR COMMON 120 25856 7-2D 7-3D 2035= 2038= 2052= 2055= 2071= 2074= 2118 ekary R*8 (202,5) VAR AUTO 298 22488 1822D 2001= 2013= 2029= 2045= 2061(2)= 2065= 2082(2)= 2086= 2094(2)= 2101= 2109 ematx R*8 (3,15) VAR COMMON 105 0 5-2D 5-4D emu R*8 (15) VAR COMMON 105 976 5-2D 5-4D 1852(2) 1990 2007 2120A emuz R*8 (10) VAR COMMON 105 1096 5-2D 5-4D extmu R*8 (202,15) VAR COMMON 120 0 7-2D 7-3D 1856= 1992= 2007 extmux R*8 (202,15) VAR AUTO 298 46728 1822D 2007= 2121 2122 gama R*8 VAR COMMON 70 8 11-3D 11-4D h R*8 (487) VAR ARG 1716D 1814D 1862 1865 1872 1880(2) 1882(2) 1884(2) i I*4 VAR AUTO 298 20 1816D 1855= 1856(3) 1857= 1881= 1882(2) 1884(2) 1885(3) 1886(3) 1888= 1891= 1892(2) 1893= 1905= 1906(2) 1907 1908 1909(4) 1915(2) 1916= 1924= 1925(4) 1937= 1938(2) 1939= 1951= 1952(2) 1953 1954 1955(4) 1961(2) 1962= 1970= 1971(4) 1981= 1982(3) 1983(3) 1984= 1991= 1992(3) 1993= 1998= 2001 2007(2) 2009 2010 2016 2017 2024 2031 2043 2048 2058 2061 2065(2) 2067 2078 2079 2082(2) 2089 2090 2091 2098 2109 2112= 2119= 2120 2121 2122 2123= ii I*4 VAR AUTO 298 46756 1816D 2107= 2109(2) 2111= iii I*4 VAR AUTO 298 46760 1816D 2108= 2109(2) 2110= im I*4 VAR AUTO 298 4 1816D 1848= 1852(2) 1856 1858 1930 1990 1992 1994= im1 I*4 VAR AUTO 298 46732 1816D 2010= 2013 2043 2045(2) 2058 2061(2) im2 I*4 VAR AUTO 298 46736 1816D 2017= 2023 imu I*4 VAR ARG 1716D 1813D 1848 2006 2119 ip1 I*4 VAR AUTO 298 46748 1816D 2078= 2079 2082 2086(2) 2091 2094(2) ip2 I*4 VAR AUTO 298 46752 1816D 2090= 2094 2097 ipol I*4 VAR COMMON 70 64 11-2D 11-4D 2033 2050 2069 j I*4 VAR AUTO 298 9532 1816D 1903= 1906(2) 1907 1908 1912 1913(2)= 1914 1915(2) 1949= 1952(2) 1953 1954 1958 1959(2)= 1960 1961(2) 2000= 2001 2002= 2006= 2007(3) 2008= 2012= 2013 2014= 2023= 2024 2029(2) 2034(2) 2035(2) 2037(2) 2038(2) 2041= 2097= 2098 2101(2) 2103= 2118(5)= 2121(4)= jk I*4 VAR AUTO 298 46740 1816D 2028= 2029(2) 2030= jprint I*4 (10) VAR COMMON 124 0 4-2D 4-3D 2117 k I*4 VAR AUTO 298 46744 1816D 2044= 2045(2) 2046= 2060= 2061(3) 2062= 2064= 2065(2) 2066= 2081= 2082(3) 2083= 2085= 2086(2) 2087= 2093= 2094(3) 2095= 2100= 2101(2) 2102= kskip R*8 VAR COMMON 66 104 8-2D 8-4D lmax I*4 VAR ARG 1716D 1813D 1862 1865 1881 1891 1894A 1904 1921 1922 1937 1940A 1950 1967 1968 lmaxm1 I*4 VAR AUTO 298 9536 1816D 1904= 1905 1923 1924 1950= 1951 1969 1970 lsphout L*4 VAR COMMON 303 0 3-2D 3-3D nc I*4 VAR ARG 1716D 1813D 1981 1985 2051(2) 2052(2) 2054(2) 2055(2) 2089 ncp1 I*4 VAR ARG 1716D 1813D 1855 1858 1914 1921 1922 1923 1928 1930 1960 1967 1968 1969 1974 1985(2) 1986(2) 1991 1998 2031 2048 2067 2070(2) 2071(2) 2073(2) 2074(2) 2097 2118 2121 2122(2) nek R*8 (202,5,202) VAR COMMON 263 0 6-2D 6-3D 2109= numek R*8 VAR COMMON 66 96 8-2D 8-4D odan R*8 (6) VAR COMMON 68 0 9-2D 9-3D 2070(2) 2071(2) 2073(2) 2074(2) pc R*8 VAR AUTO 298 40 1817D 1862= 1865= 1872 1879(2) pcpc R*8 VAR AUTO 298 7872 1817D 1879= 1880 1882 pi R*8 VAR COMMON 66 0 8-2D 8-4D ps R*8 (487) VAR ARG 1716D 1814D 1876 1877(2) 1885 pscaleforg R*8 VAR COMMON 66 88 8-2D 8-4D q R*8 VAR COMMON 70 16 11-3D 11-4D 2037 2054 2073 q1 R*8 VAR COMMON 70 24 11-3D 11-4D q12s R*8 VAR COMMON 70 56 11-3D 11-4D q2 R*8 VAR COMMON 70 32 11-3D 11-4D r R*8 VAR COMMON 66 16 8-2D 8-4D ratio R*8 VAR AUTO 298 7904 1817D 1884= 1885 1886 refdir R*8 (15) VAR COMMON 311 0 10-2D 10-3D 1858= 1930= rhon R*8 VAR COMMON 70 0 11-3D 11-4D rinv R*8 VAR COMMON 66 24 8-2D 8-4D saz R*8 (8) VAR COMMON 105 720 5-2D 5-4D saz2 R*8 (8) VAR COMMON 105 848 5-2D 5-4D sdp R*8 VAR COMMON 70 48 11-3D 11-4D sintheta R*8 VAR AUTO 298 16 1817D 1852= 1853 1860 1861= 1864(2)= 1865 sq2 R*8 VAR COMMON 66 40 8-2D 8-4D 2035 2052 2071 sqchp R*8 VAR COMMON 300 16 1-2D 1-3D 1874 sqchx R*8 VAR COMMON 300 24 1-2D 1-3D 1875 sum R*8 VAR AUTO 298 7912 1821D 1889= thetap R*8 VAR 1821D Variable declared and not used thta R*8 VAR AUTO 298 46768 1821D 2120= 2121 transph R*8 (202) VAR AUTO 298 9528 1820D 1902= 1912= 1928= 1930 1992 tsl R*8 (101) VAR COMMON 83 0 2-2D 2-3D tt R*8 (202) VAR COMMON 83 808 2-2D 2-3D 1856 1858 2024(2)A 2043(2)A 2058(2)A 2079(2)A 2091(2)A 2098(2)A ttf_sph R*8 (487) VAR AUTO 298 7864 1818D 1877= 1886(2)= 1892(2)= 1894A ttl R*8 (202) VAR COMMON 83 4040 2-2D 2-3D 1906(2) 1907 1908 1915(2) 1921 1922 1923 1952(2) 1953 1954 1961(2) 1967 1968 1969 tts R*8 (202) VAR COMMON 83 2424 2-2D 2-3D tts_sph R*8 (202) VAR AUTO 298 11176 1819D 1948= 1958= 1974= 1979 1980 1982(2) 1983(2) 1985(2) ttsf_sph R*8 (487) VAR AUTO 298 3968 1818D 1876= 1885(2)= 1938(2)= 1940A xs R*8 (487) VAR COMMON 300 32 1-2D 1-3D 1894A 1906(2) 1907 1908 1915(2) 1921 1922 1923 1940A 1952(2) 1953 1954 1961(2) 1967 1968 1969 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 1907 130 1953 199 1994 220 2030 240 2062 270 2087 300 2106 495 2123 110 1916 140 1962 200 2002 225 2041 250 2066 280 2095 310 2110 6120 2126 120 1921 150 1967 205 2008 230 2046 255 2078 290 2102 320 2111 7120 2128 125 1929 155 1975 210 2014 235 2058 260 2083 295 2103 400 2112 7130 2130 0002133 subroutine firstz(h,ps,z,thenot,fracin,lmax,ncp1) 0002134 c 0002135 c*********************************************************************** 0002136 c 0002137 cccc 0002138 c subroutine firstz 0002139 c 0002140 c purpose- 0002141 c correct the optical depths calculated for the layers of a plane 0002142 c parallel atmosphere for the sphericity of the actual atmosphere 0002143 c 0002144 c method- 0002145 c 1.using the optical depths of the layers of the standard atmos. 0002146 c calculate the slant optical path of the solar rays thru them 0002147 c using the chapman function. 0002148 c 2.then using spline interpolation calculate the slant optical 0002149 c paths in the model atmosphere. 0002150 c 0002151 c calling sequence- 0002152 c call firstz(h,ps,z,thenot,fracin,fs,f1,f2,lmax,ncp1) 0002153 c 0002154 c variables type i/o description 0002155 c --------- ---- --- ----------- 0002156 c h(487) r*8 i height of layers of standard atmosphere 0002157 c from earth center (units of r) 0002158 c ps(487) r*8 i rayleigh optical thickness of 0002159 c each layer of std. atmosphere 0002160 c z(202) r8 o total optical path of solar ray to 0002161 c reach each layer of the model atmos. 0002162 c thenot r*8 solar zenith angle 0002163 c fracin r*8 i layer*r (radius of earth in units of 0002164 c layer thickness) 0002165 c fs r*8 o cos(thenot)*z(202) 0002166 c f1 r*8 o 3/16(cos(thenot)**2) 0002167 c f2 r*8 o 3*sqrt(2)/16(sin(thenot)**2) 0002168 c lmax i*4 i # layers of standard atmos. 0002169 c ncp1 i*4 i # layers in model atmos. 0002170 c 0002171 c external references 0002172 c omerf 0002173 c splset 0002174 c 0002175 c last modified 03/14/95...dave flittner 0002176 c purpose: set pressure scale height used in gravity correction 0002177 c to rayleigh scattering od. Create new variable pscaleforg and 0002178 c pass in common block consts. 0002179 cccc 0002180 c********************************************************************** 0002181 c 0002182 c ****************************************************************** 0002183 c 0002184 c using the slant path optical thicknesses and chapman function 0002185 c this subroutine calculates dave's z matrices for primary 0002186 c scattering. 0002187 c 0002188 c ****************************************************************** 0002189 implicit integer*4(i-n),real*8 (a-h,o-z) 0002190 real *8 h(487),ps(487),zs(487),cofx(4,487) 0002191 real*8 z(202) 0002192 c 0002193 include "consts.inc" 0002194 include "out.inc" 0002195 include "thkns.inc" 0002196 include "chpmn.inc" 0002197 c 0002198 c*****calculate trig functions to be used in do loops 0002199 c 0002200 amuo = dcos(thenot*cnvrt) 0002201 if (thenot .eq. 90.0) amuo = 0. 0002202 amuosq = amuo**2 0002203 sn = dsqrt(1.-amuosq) 0002204 f1 = 0.1875*(1. + amuosq) 0002205 f2 = 0.1875*sq2*(1. - amuosq) 0002206 c 0002207 c*****calculate slant opt. path of solar rays to reach 0002208 c*****layer(i) of standard atmosphere 0002209 c 0002210 do 200 i = 1, lmax 0002211 zs(i) = 0. 0002212 raycon = sn*h(i) 0002213 if (i .eq. 1) go to 190 0002214 duma= dsqrt((h(1) + raycon)*(h(1) - raycon)) 0002215 c 0002216 c*****add slant optical paths thru each layer(j) 0002217 c*****lying between layer(1) and layer(i) 0002218 c 0002219 do 180 j = 2, i 0002220 dumb= dsqrt((h(j) + raycon)*(h(j) - raycon)) 0002221 path = fracin*(duma - dumb) 0002222 zs(i) = zs(i) + path*dxs(j) 0002223 180 duma = dumb 0002224 c 0002225 c*****find the slant opt. path to reach layer 1 from the top of 0002226 c*****the atmosphere- using chapman function approximation 0002227 c 0002228 190 amu = raycon/h(1) 0002229 amu = dsqrt(1. - amu**2) 0002230 chpp = omerf(sqchp*amu, amu, chpn) 0002231 chxx = omerf(sqchx*amu, amu, chxn) 0002232 c 0002233 c*****add the previous results to obtain total slant path zs to reach 0002234 c*****each layer i. 0002235 c 0002236 zs(i) = zs(i) + chpp*ps(1) + chxx*(dxs(1) - ps(1)) 0002237 200 continue 0002238 c 0002239 c*****fit a spline between xs=log(vert. path) and zs=log(slant path) 0002240 c*****through the standard atmosphere 0002241 c 0002242 do 215 i = 1, lmax 0002243 215 zs(i) = dlog(zs(i)) 0002244 call splset(xs,zs,cofx,lmax) 0002245 c 0002246 c*****for each layer of model atmosphere find two layers in the 0002247 c*****standard atmosphere straddling it and find total slant optical 0002248 c*****path (z) to reach each layer of model atmosphere- 0002249 c***** using spline interpolation 0002250 c 0002251 z(1) = 1.0 0002252 j = 2 0002253 lmaxm1 = lmax - 1 0002254 do 230 i = 1, lmaxm1 0002255 if (ttl(j) .le. xs(i) .or. ttl(j) .gt. xs(i+1)) go to 230 0002256 220 dum1 = xs(i+1) - ttl(j) 0002257 dum2 = ttl(j) - xs(i) 0002258 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0002259 1dum2**2 + cofx(4,i)) 0002260 dum3 = dexp(dum3) 0002261 z(j) = dexp(-dum3) 0002262 j = j + 1 0002263 if (j .gt. ncp1) go to 240 0002264 if (ttl(j) .gt. xs(i) .and. ttl(j) .le. xs(i+1)) go to 220 0002265 230 continue 0002266 c 0002267 c*****find z for the bottom layer by extrapolation if it was not 0002268 c*****obtained during the above interpolation 0002269 c 0002270 240 if (ttl(ncp1) .le. xs(lmax)) go to 245 0002271 dum1 = xs(lmax) - ttl(ncp1) 0002272 dum2 = ttl(ncp1) - xs(lmaxm1) 0002273 i = lmaxm1 0002274 dum3 = dum1*(cofx(1,i)*dum1**2 + cofx(3,i)) + dum2*(cofx(2,i)* 0002275 1dum2**2 + cofx(4,i)) 0002276 dum3 = dexp(dum3) 0002277 z(ncp1) = dexp(-dum3) 0002278 245 continue 0002279 fs = amuo*z(ncp1) 0002280 c write (6,'(i4,e12.4)') (i,z(i),i=1,ncp1) 0002281 return 0002282 end INCLUDE FILES FileNo File name 1 consts.inc 2 out.inc 3 thkns.inc 4 chpmn.inc ENTRY POINTS Name Type BlockNo firstz SUBR 351 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dcos INTRINSIC 2200 dexp INTRINSIC 2260 2261 2276 2277 dlog INTRINSIC 2243 dsqrt INTRINSIC 2203 2214 2220 2229 firstz SUBR 2133D omerf R*8 EXTERNAL 2230 2231 splset SUBR EXTERNAL 2244 COMMON BLOCKS Name Size BlockNo chpmn_ 7824 300 consts_ 112 66 out_ 3256 117 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References amu R*8 VAR AUTO 351 4000 2228= 2229(2)= 2230(2)A 2231(2)A amuo R*8 VAR AUTO 351 8 2200= 2201= 2202 2279 amuosq R*8 VAR AUTO 351 16 2202= 2203 2204 2205 c1415 R*8 VAR COMMON 66 72 1-2D 1-4D c215 R*8 VAR COMMON 66 48 1-2D 1-4D c2815 R*8 VAR COMMON 66 80 1-2D 1-4D c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D c815 R*8 VAR COMMON 66 56 1-2D 1-4D chpn R*8 VAR COMMON 300 0 4-2D 4-3D 2230A chpp R*8 VAR AUTO 351 4008 2230= 2236 chxn R*8 VAR COMMON 300 8 4-2D 4-3D 2231A chxx R*8 VAR AUTO 351 4016 2231= 2236 cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D 2200 cofx R*8 (4,487) VAR AUTO 351 19608 2190D 2244A 2258(4) 2274(4) cons R*8 VAR COMMON 66 32 1-2D 1-4D dtsp R*8 (202) VAR COMMON 83 5656 3-2D 3-3D dtts R*8 (202) VAR COMMON 83 7272 3-2D 3-3D dum1 R*8 VAR AUTO 351 19624 2256= 2258(2) 2271= 2274(2) dum2 R*8 VAR AUTO 351 19632 2257= 2258(2) 2272= 2274(2) dum3 R*8 VAR AUTO 351 19640 2258= 2260(2)= 2261 2274= 2276(2)= 2277 duma R*8 VAR AUTO 351 3968 2214= 2221 2223= dumb R*8 VAR AUTO 351 3984 2220= 2221 2223 dxs R*8 (487) VAR COMMON 300 3928 4-2D 4-3D 2222 2236 eiaz1 R*8 (15,8) VAR COMMON 117 360 2-2D 2-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 2-2D 2-3D eizero R*8 (15) VAR COMMON 117 240 2-2D 2-3D f1 R*8 VAR AUTO 351 40 2204= f2 R*8 VAR AUTO 351 48 2205= fracin R*8 VAR ARG 2133D 2221 fs R*8 VAR COMMON 117 2288 2-2D 2-3D 2279= gg R*8 VAR COMMON 117 2280 2-2D 2-3D h R*8 (487) VAR ARG 2133D 2190D 2212 2214(2) 2220(2) 2228 i I*4 VAR AUTO 351 52 2210= 2211 2212 2213 2219 2222(2) 2236(2) 2237= 2242= 2243(3)= 2254= 2255(2) 2256 2257 2258(4) 2264(2) 2265= 2273= 2274(4) j I*4 VAR AUTO 351 3972 2219= 2220(2) 2222 2223= 2252= 2255(2) 2256 2257 2261 2262(2)= 2263 2264(2) kskip R*8 VAR COMMON 66 104 1-2D 1-4D lmax I*4 VAR ARG 2133D 2210 2242 2244A 2253 2270 2271 lmaxm1 I*4 VAR AUTO 351 19612 2253= 2254 2272 2273 ncp1 I*4 VAR ARG 2133D 2263 2270 2271 2272 2277 2279 numek R*8 VAR COMMON 66 96 1-2D 1-4D path R*8 VAR AUTO 351 3992 2221= 2222 pi R*8 VAR COMMON 66 0 1-2D 1-4D ps R*8 (487) VAR ARG 2133D 2190D 2236(2) pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D qr R*8 (11) VAR COMMON 117 32 2-2D 2-3D r R*8 VAR COMMON 66 16 1-2D 1-4D raycon R*8 VAR AUTO 351 3960 2212= 2214(2) 2220(2) 2228 rinv R*8 VAR COMMON 66 24 1-2D 1-4D sb R*8 (4) VAR COMMON 117 0 2-2D 2-3D sn R*8 VAR AUTO 351 32 2203= 2212 sq2 R*8 VAR COMMON 66 40 1-2D 1-4D 2205 sqchp R*8 VAR COMMON 300 16 4-2D 4-3D 2230 sqchx R*8 VAR COMMON 300 24 4-2D 4-3D 2231 thenot R*8 VAR ARG 2133D 2200 2201 tnstr R*8 (15) VAR COMMON 117 120 2-2D 2-3D totint R*8 (15,8) VAR COMMON 117 2296 2-2D 2-3D tsl R*8 (101) VAR COMMON 83 0 3-2D 3-3D tt R*8 (202) VAR COMMON 83 808 3-2D 3-3D ttl R*8 (202) VAR COMMON 83 4040 3-2D 3-3D 2255(2) 2256 2257 2264(2) 2270 2271 2272 tts R*8 (202) VAR COMMON 83 2424 3-2D 3-3D xs R*8 (487) VAR COMMON 300 32 4-2D 4-3D 2244A 2255(2) 2256 2257 2264(2) 2270 2271 2272 z R*8 (202) VAR ARG 2133D 2191D 2251= 2261= 2277= 2279 zs R*8 (487) VAR AUTO 351 3952 2190D 2211= 2222(2)= 2236(2)= 2243(2)= 2244A LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 180 2223 190 2228 200 2237 215 2243 220 2256 230 2265 240 2270 245 2278 0002283 subroutine frstz2(z,thenot,fsx,f1,f2,ncp1) 0002284 c ****************************************************************** 0002285 c subroutine frstz2 0002286 c 0002287 c purpose 0002288 c this routine is used to calculate the zero order source 0002289 c functions for a parallel plane atmos. model. 0002290 c 0002291 c method 0002292 c the zero order source functions are computed by calculating 0002293 c the intensity of the incident solar radiation at each source 0002294 c function level using attenuation factors calculated for a 0002295 c parallel plane atmosphere. 0002296 c 0002297 c calling sequence 0002298 c call frstz2(z,thnot,fsx,f1,f2,ncp1) 0002299 c 0002300 c variable type i/o description 0002301 c -------- ---- --- ----------- 0002302 c 0002303 c z(202) r*8 o zero order reduced source functions 0002304 c thnot r*8i current solar zenith angle 0002305 c fsx r*8 o direct flux reaching ground 0002306 c f1 r*8 o constant 0002307 c f2 r*8 o computational constant 0002308 c ncp1 i*4 i # levels in model atmos. 0002309 c 0002310 c analysis and programming 0002311 c k. f. klenk , p. m. smith sasc aug 77 0002312 c 0002313 c modifications (date name purpose) 0002314 c last modified by zia ahmad 0002315 c purpose: to include the effect of molecular anisotropy 0002316 c 0002317 c last modified 03/14/95...dave flittner 0002318 c purpose: set pressure scale height used in gravity correction 0002319 c to rayleigh scattering od. Create new variable pscaleforg and 0002320 c pass in common block consts. 0002321 c*********************************************************************** 0002322 c 0002323 implicit integer*4(i-n),real*8 (a-h,o-z) 0002324 c real *8 h(487),ps(487),xs(487),dxs(487),zs(487),cofx(4,487) 0002325 real *8 z(202) 0002326 c 0002327 include "consts.inc" 0002328 include "thkns.inc" 0002329 include "chpmn.inc" 0002330 include "out.inc" 0002331 c 0002332 c new statement 0002333 include "depolt.inc" 0002334 c end of new statement 0002335 c 0002336 amuo = dcos(thenot*cnvrt) 0002337 if (thenot .eq. 90.0) amuo = 0. 0002338 amuosq = amuo**2 0002339 sn = dsqrt(1.-amuosq) 0002340 c new statements 0002341 if(ipol.eq.0)then 0002342 f1 = 0.1875d0*(1.d0 + amuosq) 0002343 f2 = 0.1875d0*sq2*(1.d0 - amuosq) 0002344 else 0002345 f1=0.25d0*q1*(1.0d0+amuosq+2.0d0*q) 0002346 f2=0.25d0*q1*delp*(1.0d0-amuosq) 0002347 endif 0002348 c*****parallel plane atmosphere 0002349 do 200 j=1,ncp1 0002350 z(j)=dexp(-tt(j)/amuo) 0002351 200 continue 0002352 c 0002353 fsx=amuo*z(ncp1) 0002354 fs=fsx 0002355 return 0002356 end INCLUDE FILES FileNo File name 1 consts.inc 2 thkns.inc 3 chpmn.inc 4 out.inc 5 depolt.inc ENTRY POINTS Name Type BlockNo frstz2 SUBR 365 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dcos INTRINSIC 2336 dexp INTRINSIC 2350 dsqrt INTRINSIC 2339 frstz2 SUBR 2283D COMMON BLOCKS Name Size BlockNo chpmn_ 7824 300 consts_ 112 66 depolt_ 68 70 out_ 3256 117 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References amuo R*8 VAR AUTO 365 8 2336= 2337= 2338 2350 2353 amuosq R*8 VAR AUTO 365 16 2338= 2339 2342 2343 2345 2346 c1415 R*8 VAR COMMON 66 72 1-2D 1-4D c215 R*8 VAR COMMON 66 48 1-2D 1-4D c2815 R*8 VAR COMMON 66 80 1-2D 1-4D c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D c815 R*8 VAR COMMON 66 56 1-2D 1-4D chpn R*8 VAR COMMON 300 0 3-2D 3-3D chxn R*8 VAR COMMON 300 8 3-2D 3-3D cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D 2336 cons R*8 VAR COMMON 66 32 1-2D 1-4D delp R*8 VAR COMMON 70 40 5-3D 5-4D 2346 dtsp R*8 (202) VAR COMMON 83 5656 2-2D 2-3D dtts R*8 (202) VAR COMMON 83 7272 2-2D 2-3D dxs R*8 (487) VAR COMMON 300 3928 3-2D 3-3D eiaz1 R*8 (15,8) VAR COMMON 117 360 4-2D 4-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 4-2D 4-3D eizero R*8 (15) VAR COMMON 117 240 4-2D 4-3D f1 R*8 VAR ARG 2283D 2342= 2345= f2 R*8 VAR ARG 2283D 2343= 2346= fs R*8 VAR COMMON 117 2288 4-2D 4-3D 2354= fsx R*8 VAR ARG 2283D 2353= 2354 gama R*8 VAR COMMON 70 8 5-3D 5-4D gg R*8 VAR COMMON 117 2280 4-2D 4-3D ipol I*4 VAR COMMON 70 64 5-2D 5-4D 2341 j I*4 VAR AUTO 365 36 2349= 2350(2) 2351= kskip R*8 VAR COMMON 66 104 1-2D 1-4D ncp1 I*4 VAR ARG 2283D 2349 2353 numek R*8 VAR COMMON 66 96 1-2D 1-4D pi R*8 VAR COMMON 66 0 1-2D 1-4D pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D q R*8 VAR COMMON 70 16 5-3D 5-4D 2345 q1 R*8 VAR COMMON 70 24 5-3D 5-4D 2345 2346 q12s R*8 VAR COMMON 70 56 5-3D 5-4D q2 R*8 VAR COMMON 70 32 5-3D 5-4D qr R*8 (11) VAR COMMON 117 32 4-2D 4-3D r R*8 VAR COMMON 66 16 1-2D 1-4D rhon R*8 VAR COMMON 70 0 5-3D 5-4D rinv R*8 VAR COMMON 66 24 1-2D 1-4D sb R*8 (4) VAR COMMON 117 0 4-2D 4-3D sdp R*8 VAR COMMON 70 48 5-3D 5-4D sn R*8 VAR AUTO 365 32 2339= sq2 R*8 VAR COMMON 66 40 1-2D 1-4D 2343 sqchp R*8 VAR COMMON 300 16 3-2D 3-3D sqchx R*8 VAR COMMON 300 24 3-2D 3-3D thenot R*8 VAR ARG 2283D 2336 2337 tnstr R*8 (15) VAR COMMON 117 120 4-2D 4-3D totint R*8 (15,8) VAR COMMON 117 2296 4-2D 4-3D tsl R*8 (101) VAR COMMON 83 0 2-2D 2-3D tt R*8 (202) VAR COMMON 83 808 2-2D 2-3D 2350 ttl R*8 (202) VAR COMMON 83 4040 2-2D 2-3D tts R*8 (202) VAR COMMON 83 2424 2-2D 2-3D xs R*8 (487) VAR COMMON 300 32 3-2D 3-3D z R*8 (202) VAR ARG 2283D 2325D 2350= 2353 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 200 2351 0002357 subroutine geopro(x) 0002358 c 0002359 c********************************************************************** 0002360 cccc 0002361 c subroutine geopro 0002362 c 0002363 c version aug 22,1977 0002364 c 0002365 c purpose 0002366 c 0002367 c compute extrapolated value of argument 0002368 c 0002369 c method 0002370 c 0002371 c using last three iterated values of argument, a geometric 0002372 c series approx. is used to compute extrapolated terms. 0002373 c 0002374 c calling sequence 0002375 c 0002376 c call geopro(x) 0002377 c 0002378 c variable type i/o description 0002379 c -------- ---- --- ----------- 0002380 c 0002381 c x(4) r*8 i/o argument to be extrapolated 0002382 c x(1),x(2),x(3) contain last three 0002383 c iteration values of argument to be 0002384 c extrapolated. extrapolated term is 0002385 c stored in x(4) 0002386 c 0002387 c external references 0002388 c none 0002389 c 0002390 c common areas referenced 0002391 c none 0002392 c 0002393 c analysis and programming 0002394 c k.f. klenk p.m. smith sasc, aug 22 1977 0002395 c 0002396 c modifications (date name purpose) 0002397 c 0002398 c last modified 11/18/92 bye zia ahmad 0002399 c fixed the overflow problem 0002400 c 0002401 cccc 0002402 c********************************************************************** 0002403 c 0002404 implicit integer*4(i-n),real*8(a-h,o-z) 0002405 c 0002406 real*8 x(4) 0002407 c 0002408 a=x(3)-x(2) 0002409 b=x(2)-x(1) 0002410 c = dabs(b-a) 0002411 if (c .gt. 1.0d-9) then 0002412 x(4) = x(2) + a*b/(b-a) 0002413 else 0002414 x(4) = x(3) 0002415 endif 0002416 return 0002417 end ENTRY POINTS Name Type BlockNo geopro SUBR 132 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dabs INTRINSIC 2410 geopro SUBR 2357D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 VAR AUTO 132 8 2408= 2410 2412(2) b R*8 VAR AUTO 132 16 2409= 2410 2412(2) c R*8 VAR AUTO 132 24 2410= 2411 x R*8 (4) VAR ARG 2357D 2406D 2408(2) 2409(2) 2412(2)= 2414(2)= 0002418 logical function get_coef(start, ending, lambda, c0, c1, c2, beta, 0002419 * rhon) 0002420 C======================================================================C 0002421 C C 0002422 C FUNCTION : GET_COEF C 0002423 C C 0002424 C PURPOSE: This subroutine reads the ozone absorption and C 0002425 C Rayleigh scattering coefficients and splines the C 0002426 C to the correct wavelenght C 0002427 C C 0002428 C USE: C 0002429 C call get_coef(lambda, c0, c1, c2, beta) C 0002430 C C 0002431 C PARAMETERS : C 0002432 C C 0002433 C Lambda - Real*4 input parameter. The wavelength in C 0002434 C angstroms. C 0002435 C c0, c1, c2 - Real*4 output. Ozone absoption coef. C 0002436 C Alpha = c0 + c1 * T + c2 * T**2, where C 0002437 C T is the temperature in Celsius. C 0002438 C beta - Real*4 Output. Rayleigh coefficient at that C 0002439 C wavelength. C 0002440 C C 0002441 C SOURCE: DONALD J. RICHARDSON C 0002442 C HUGHES STX C 0002443 C C 0002444 C LANGUAGE: FORTRAN 77 C 0002445 C C 0002446 C DATE STARTED : September 28, 1994 C 0002447 C C 0002448 C LATEST REVISION: September 28, 1994 C 0002449 C C 0002450 C C 0002451 C======================================================================C 0002452 save 0002453 implicit none 0002454 ! 0002455 ! Parameters 0002456 ! 0002457 character*80 data_file_name_def 0002458 parameter(data_file_name_def = 'BASS.DAT') 0002459 ! 0002460 ! Calling Parameters 0002461 ! 0002462 real*8 start ! Input -- Starting wavelength 0002463 real*8 ending ! Input -- ending wavelength 0002464 real*8 lambda ! Output -- Wavelength 0002465 real*8 c0 ! Output -- Ozone absorption coef (const term) 0002466 real*8 c1 ! Output -- Ozone Absorption coef (T(c deg) term) 0002467 real*8 c2 ! Output -- Ozone Absorption coef (T(c deg)^2 term) 0002468 real*8 beta ! Output -- Rayleigh scattering coef 0002469 real*8 rhon ! Output -- depolarization factor 0002470 ! 0002471 ! Local Variables 0002472 ! 0002473 logical first_time /.true./ 0002474 0002475 integer*4 iunit 0002476 integer*4 iostat 0002477 integer*4 num 0002478 integer*4 additional 0002479 0002480 character*80 junk 0002481 character*80 data_file_name 0002482 0002483 ! 0002484 ! If this is the first time read the data file and initialize spline. 0002485 ! 0002486 if (first_time) then 0002487 ! 0002488 ! Get a free logical unit number 0002489 ! 0002490 call get_lun(iunit) 0002491 ! 0002492 ! Check to see if all LUN are in use 0002493 ! 0002494 if (iunit .lt. 0) then 0002495 write(*, 0002496 * '(''No Logical Units available to be open in get_coef'')') 0002497 stop 'No LUN avaiable' 0002498 end if 0002499 ! 0002500 ! Open coefficient data file 0002501 ! 0002502 first_time = .false. 0002503 call getenv('ABSORP_COEF', data_file_name) 0002504 if (data_file_name .eq. ' ') then 0002505 c print*,'Absorption coefficient enviromental variable ', 0002506 c * '(ABSORP_COEF) was not found.' 0002507 c print*,'Using the default absoption coef. file', 0002508 c * data_file_name_def 0002509 data_file_name = data_file_name_def 0002510 end if 0002511 0002512 open (iunit, file=data_file_name, status = 'old', err = 200) 0002513 read(iunit,'(a)') junk ! Header line 0002514 ! 0002515 ! locate the first data set 0002516 ! 0002517 90 read(iunit,*,end=100) lambda, c0, c1, c2, beta, rhon 0002518 if (lambda .lt. start) go to 90 0002519 get_coef = lambda .le. ending 0002520 return 0002521 end if 0002522 ! 0002523 ! Getting next data set 0002524 ! 0002525 read (iunit,*,end = 100) lambda, c0, c1, c2, beta, rhon 0002526 get_coef = lambda .le. ending 0002527 return 0002528 ! 0002529 ! End of file reached.... No more data 0002530 ! 0002531 100 get_coef = .false. 0002532 return 0002533 200 print*, 'Error in opening the coefficient database:', 0002534 * data_file_name 0002535 stop 'Error in opening coefficient database' 0002536 end ENTRY POINTS Name Type BlockNo get_coef L*4 374 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References get_coef L*4 2418D 2519= 2526= 2531= get_lun SUBR EXTERNAL 2490 getenv SUBR EXTERNAL 2503 PARAMETERS Name Type References data_file_name_def CH*80 2457D 2458D 2509 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References additional I*4 VAR 2478D Variable declared and not used beta R*8 VAR ARG 2418D 2468D 2517= 2525= c0 R*8 VAR ARG 2418D 2465D 2517= 2525= c1 R*8 VAR ARG 2418D 2466D 2517= 2525= c2 R*8 VAR ARG 2418D 2467D 2517= 2525= data_file_name CH*80 VAR STATIC 384 0 2481D 2503A 2504 2509= 2512 2533 ending R*8 VAR ARG 2418D 2463D 2519 2526 first_time L*4 VAR DATA 375 0 2473(2)I 2486 2502= iostat I*4 VAR 2476D Variable declared and not used iunit I*4 VAR STATIC 377 0 2475D 2490A 2494 2512 2513 2517 2525 junk CH*80 VAR STATIC 395 0 2480D 2513= lambda R*8 VAR ARG 2418D 2464D 2517= 2518 2519 2525= 2526 num I*4 VAR 2477D Variable declared and not used rhon R*8 VAR ARG 2418D 2469D 2517= 2525= start R*8 VAR ARG 2418D 2462D 2518 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 90 2517 100 2531 200 2533 0002537 subroutine get_lun (ivalue) 0002538 C======================================================================C 0002539 C C 0002540 C SUBROUTINE : GET_LUN C 0002541 C C 0002542 C PURPOSE: To keep logical unit numbers straight, and issues new C 0002543 C ones when necessary. The entry point FREE_LUN closes C 0002544 C file and allows the logical unit number to be reused. C 0002545 C C 0002546 C USE: C 0002547 C CALL GET_LUN (IUNIT) C 0002548 C CALL FREE_LUN (IUNIT) C 0002549 C C 0002550 C PARAMETERS : C 0002551 C C 0002552 C IUNIT --- In GET_LUN, it is the returned logical unit C 0002553 C number. In FREE_LUN, it is the input LUN to C 0002554 C close and to be reused. C 0002555 C C 0002556 C SOURCE: DONALD J. RICHARDSON C 0002557 C HUGHES STX C 0002558 C C 0002559 C LANGUAGE: FORTRAN 77 C 0002560 C C 0002561 C DATE STARTED : September 9, 1994 C C 0002562 C C 0002563 C LATEST REVISION: September 12, 1994 C 0002564 C C 0002565 C C 0002566 C======================================================================C 0002567 implicit none 0002568 0002569 integer*4 min_lun, max_lun 0002570 parameter (min_lun = 10, max_lun=100) 0002571 0002572 logical open_stat 0002573 integer*4 ivalue 0002574 integer*4 i 0002575 0002576 do i = min_lun, max_lun 0002577 inquire (i, opened = open_stat) 0002578 if (.not. open_stat) then 0002579 ivalue = i 0002580 return 0002581 end if 0002582 end do 0002583 0002584 write (0,*) 'All the Logical Unit Numbers between ',min_lun, 0002585 * ' and ', max_lun, ' are all in use.' 0002586 ivalue = -1 0002587 return 0002588 0002589 entry free_lun (ivalue) 0002590 0002591 close (ivalue) 0002592 0002593 return 0002594 end ENTRY POINTS Name Type BlockNo free_lun SUBR 418 get_lun SUBR 376 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References free_lun SUBR 2589D get_lun SUBR 2537D PARAMETERS Name Type References max_lun I*4 2569D 2570D 2576 2584 min_lun I*4 2569D 2570D 2576 2584 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References i I*4 VAR AUTO 376 4 2574D 2576= 2577 2579 2582= ivalue I*4 VAR ARG 2537D 2573D 2579= 2586= 2589D 2591 open_stat L*4 VAR AUTO 376 8 2572D 2577A 2578 0002595 subroutine iniclz 0002596 c*********************************************************************** 0002597 c 0002598 c this subroutine initializes various numerical constants freque- 0002599 c ntly used in various subroutines. 0002600 c 0002601 c last modified 03/10/95...dave flittner 0002602 c purpose: set radius of earth equal to value used to find earth 0002603 c position (6378.145 km). 0002604 c 0002605 c last modified 03/14/95...dave flittner 0002606 c purpose: set pressure scale height used in gravity correction 0002607 c to rayleigh scattering od. Create new variable pscaleforg and 0002608 c pass in common block consts. 0002609 c*********************************************************************** 0002610 implicit integer*4(i-n), real*8(a-h,o-z) 0002611 c 0002612 include "consts.inc" 0002613 include "es.inc" 0002614 c 0002615 c pi = dacos(-1.0d+00) 0002616 pi = 3.1415926535d+00 0002617 cnvrt = pi / 180.d+00 0002618 c 0002619 c***** r is the radius of the earth in km. 0002620 c 0002621 r = 6378.145d+00 !def 0002622 rinv = 1.d+00 / r 0002623 cons = r / 6393.d+00 0002624 sq2 = dsqrt(2.d+00) 0002625 c215 = 2.d+00 / 15.0d+00 0002626 c815 = 4.0d+00 * c215 0002627 c38sq2 = 0.375d+00 * sq2 0002628 c1415 = 0.9333333333d0 0002629 c2815 = 1.8666666667d0 0002630 pscaleforg = 6.95d0/r !def 0002631 kskip=0 0002632 numek = 606 0002633 c 0002634 odan(1)=1.d0 0002635 do 10 i=2,6 0002636 odan(i)=1.d0/float(i-1) 0002637 10 continue 0002638 c 0002639 return 0002640 end INCLUDE FILES FileNo File name 1 consts.inc 2 es.inc ENTRY POINTS Name Type BlockNo iniclz SUBR 422 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dsqrt INTRINSIC 2624 float INTRINSIC 2636 iniclz SUBR 2595D COMMON BLOCKS Name Size BlockNo consts_ 112 66 es_ 144 68 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References c1415 R*8 VAR COMMON 66 72 1-2D 1-4D 2628= c215 R*8 VAR COMMON 66 48 1-2D 1-4D 2625= 2626 c2815 R*8 VAR COMMON 66 80 1-2D 1-4D 2629= c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D 2627= c815 R*8 VAR COMMON 66 56 1-2D 1-4D 2626= cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D 2617= cons R*8 VAR COMMON 66 32 1-2D 1-4D 2623= e R*8 (6) VAR COMMON 68 48 2-2D 2-3D eek R*8 (6) VAR COMMON 68 96 2-2D 2-3D i I*4 VAR AUTO 422 4 2635= 2636(2) 2637= kskip R*8 VAR COMMON 66 104 1-2D 1-4D 2631= numek R*8 VAR COMMON 66 96 1-2D 1-4D 2632= odan R*8 (6) VAR COMMON 68 0 2-2D 2-3D 2634= 2636= pi R*8 VAR COMMON 66 0 1-2D 1-4D 2616= 2617 pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D 2630= r R*8 VAR COMMON 66 16 1-2D 1-4D 2621= 2622 2623 2630 rinv R*8 VAR COMMON 66 24 1-2D 1-4D 2622= sq2 R*8 VAR COMMON 66 40 1-2D 1-4D 2624= 2627 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 2637 0002641 subroutine iniclz1 0002642 c*********************************************************************** 0002643 c 0002644 c last modified by zia ahmad 9/10/93 0002645 c purpose: to include the effect of molecular anisotropy 0002646 c 0002647 c*********************************************************************** 0002648 implicit integer*4(i-n), real*8(a-h,o-z) 0002649 c new statement 0002650 include "depolt.inc" 0002651 c end of new statement 0002652 c 0002653 c new statements 0002654 if(ipol.eq.1)then 0002655 c rhon=0.035d0 0002656 gama=rhon/(2.0d0-rhon) 0002657 q2=(1.0d0-gama)/(1.0d0+2.0d0*gama) 0002658 q1=0.75d0*q2 0002659 q=(2.0d0*gama)/(1.0d0-gama) 0002660 sdp=1.0d0+q 0002661 delp=dsqrt(2.0d0+3.0d0*q) 0002662 q12s=q1/(2.0d0*sdp) 0002663 endif 0002664 c end of new statements 0002665 c 0002666 c write(33,500)ipol 0002667 500 format('sub iniclz1 ... ipol=',i2) 0002668 c write(33,501)rhon,gama,q,q1,q2,sdp,delp,q12s 0002669 501 format('sub iniclz..rhon etc.'/1p6e12.4/1p2e12.4) 0002670 return 0002671 end INCLUDE FILES FileNo File name 1 depolt.inc ENTRY POINTS Name Type BlockNo iniclz1 SUBR 427 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dsqrt INTRINSIC 2661 iniclz1 SUBR 2641D COMMON BLOCKS Name Size BlockNo depolt_ 68 70 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References delp R*8 VAR COMMON 70 40 1-3D 1-4D 2661= gama R*8 VAR COMMON 70 8 1-3D 1-4D 2656= 2657(2) 2659(2) ipol I*4 VAR COMMON 70 64 1-2D 1-4D 2654 q R*8 VAR COMMON 70 16 1-3D 1-4D 2659= 2660 2661 q1 R*8 VAR COMMON 70 24 1-3D 1-4D 2658= 2662 q12s R*8 VAR COMMON 70 56 1-3D 1-4D 2662= q2 R*8 VAR COMMON 70 32 1-3D 1-4D 2657= 2658 rhon R*8 VAR COMMON 70 0 1-3D 1-4D 2656(2) sdp R*8 VAR COMMON 70 48 1-3D 1-4D 2660= 2662 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 500 2667 501 2669 0002672 subroutine intsum 0002673 c 0002674 c last modified 03/07/95...dave flittner 0002675 c purpose: Spherical correction to the integration of the out-going 0002676 c beam for each view angle. Lines changed denoted by !def 0002677 c 0002678 implicit real*8(a-h,o-z),integer*4(i-n) 0002679 c 0002680 include "contrl.inc" 0002681 include "out.inc" 0002682 include "totals.inc" 0002683 include "emm.inc" 0002684 include "atmos.inc" 0002685 include "in.inc" 0002686 include "depolt.inc" 0002687 include "buff1.inc" 0002688 include "buff2.inc" 0002689 include "buff3.inc" 0002690 include "buff4.inc" 0002691 include "crefdir.inc" 0002692 c 0002693 real*8 tt(15) 0002694 real*8 totn(15,8,11) 0002695 real*8 temp(15) 0002696 c 0002697 c**** compute total reflected intensity at top of atmosphere ristar 0002698 c**** loop over albedos and polar look angles 0002699 c 0002700 itmaxp=itmax+1 0002701 maxpp=itmaxp+1 0002702 do 100 i=1,nalb 0002703 c 0002704 c**** compute ig, ground reflected radiation 0002705 c 0002706 tensig(i)=(fs+gg)*qr(i) 0002707 do 200 j=1,imu 0002708 c 0002709 do 124 it=1,maxpp 0002710 ttz(it,j)=(fs+ggz(it))*(tnstrz(it,j)+refdir(j)) !def 0002711 124 continue 0002712 tt(j)=(fs+gg)*(tnstr(j)+refdir(j)) !def 0002713 ttlp(j)=(fs+gg)*(tnstrl(j)+0.50d0*refdir(j)) !def 0002714 ttrp(j)=(fs+gg)*(tnstrr(j)+0.50d0*refdir(j)) !def 0002715 temp(j)=ttlp(j)+ttrp(j) 0002716 c write(33,123)fs,gg,refdir(j),tnstr(j),tt(j),temp(j) 0002717 123 format('intsum...fs,gg,refdir,tnstr(j),tt,temp',6f8.4) 0002718 c**** compute sum of direct (refdir) and diffuse (tnstr) reflected inten 0002719 c 0002720 ristar(j,i)=tensig(i)*(tnstr(j)+refdir(j)) !def 0002721 200 continue 0002722 100 continue 0002723 c 0002724 c**** sum ristar and totint to calculate the total radiation (scattered 0002725 c**** and reflected (izero+i1+i2+istar) at top of atmosphere. 0002726 c 0002727 do 500 i=1,imu 0002728 do 400 j=1,iazmth 0002729 do 300 k=1,nalb 0002730 c 0002731 total(i,j,k)=totint(i,j)+ristar(i,k) 0002732 totn(i,j,k)=-100.0*dlog10(total(i,j,k)) 0002733 c if(i.eq.1 .and. j.eq.1 .and. k.eq.1)then 0002734 c write(33,666)i,j,k,thnot(imuz),thta(i),azmth(j),alb(k), 0002735 c 1 total(i,j,k),totn(i,j,k) 0002736 666 format('i,j,k,total,totn',3i3,3f7.1,f7.3,1p2e11.3) 0002737 c endif 0002738 300 continue 0002739 400 continue 0002740 500 continue 0002741 c 0002742 c compute degree of polarization 0002743 c 0002744 do i=1,imu 0002745 do j=1,iazmth 0002746 do k=1,nalb 0002747 gistl=qr(k)*ttlp(i) 0002748 gistr=qr(k)*ttrp(i) 0002749 eittl(i,j,k)=eitl(i,j)+gistl 0002750 eittr(i,j,k)=eitr(i,j)+gistr 0002751 eitotz(i,j,k)=eittl(i,j,k)+eittr(i,j,k) 0002752 polz(i,j,k)=dsqrt((eittl(i,j,k)-eittr(i,j,k))**2 0002753 1 +eitu(i,j)**2)/eitotz(i,j,k) 0002754 if (eittl(i,j,k) .gt. eittr(i,j,k)) 0002755 * polz(i,j,k) = -polz(i,j,k) 0002756 c 0002757 c write(33,'(''intsum...eittl,eittr,eitu'',3f9.5)') 0002758 c * eittl(i,j,k), eittr(i,j,k), eitu(i,j) 0002759 c write(33,135)i,j,k,tnstrl(i),tnstrr(i),qr(k),ttlp(i), 0002760 c 1 ttrp(i),eitotz(i,j,k),polz(i,j,k) 0002761 enddo 0002762 enddo 0002763 enddo 0002764 135 format('im,jaz,kalb,tnstrl,tnstrr,qr,ttlp,ttrp,eitotz,polz'/ 0002765 1 3i4,7f9.5) 0002766 0002767 0002768 pi=dacos(-1.0d0) 0002769 c print izero, i1,i2 etc as func. of sza and view angle 0002770 c 0002771 c write(33,132) 0002772 132 format('theta0','theta',t15,'i0',t25,'i1',t35,'i2',t45,'t', 0002773 1 t55,'sb',t65,'rho',t73,'ipol'/) 0002774 do i=1,imu 0002775 tfunc=tt(i)/pi 0002776 xizero=eizero(i)/pi 0002777 xi1=eiaz1(i,1)/pi 0002778 xi2=eiaz2(i,1)/pi 0002779 c write(33,133)thnot(imuz),thta(i),xizero,xi1,xi2,tfunc,sb(4), 0002780 c 1 rhon,ipol 0002781 133 format(2f5.0,1x,6f10.5,1x,i3) 0002782 enddo 0002783 c write(33,134) 0002784 134 format(/ ) 0002785 c 0002786 return 0002787 end INCLUDE FILES FileNo File name 1 contrl.inc 2 out.inc 3 totals.inc 4 emm.inc 5 atmos.inc 6 in.inc 7 depolt.inc 8 buff1.inc 9 buff2.inc 10 buff3.inc 11 buff4.inc 12 crefdir.inc ENTRY POINTS Name Type BlockNo intsum SUBR 221 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dacos INTRINSIC 2768 dlog10 INTRINSIC 2732 dsqrt INTRINSIC 2752 intsum SUBR 2672D COMMON BLOCKS Name Size BlockNo atmos_ 48 87 buff1_ 1392 166 buff2_ 18432 128 buff3_ 3120 188 buff4_ 43320 444 contrl_ 2808 85 crefdir_ 120 311 depolt_ 68 70 emm_ 1176 105 in_ 196 126 out_ 3256 117 totals_ 11968 435 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 4-2D 4-4D alb R*8 (11) VAR COMMON 85 200 1-3D 1-5D alfaef R*8 VAR COMMON 85 2792 1-5D alpha0 R*8 VAR COMMON 87 0 5-2D 5-3D azmth R*8 (8) VAR COMMON 85 136 1-3D 1-5D beta R*8 VAR COMMON 87 8 5-2D 5-3D caz R*8 (8) VAR COMMON 105 784 4-2D 4-4D caz2 R*8 (8) VAR COMMON 105 912 4-2D 4-4D code R*8 VAR COMMON 87 16 5-3D delp R*8 VAR COMMON 70 40 7-3D 7-4D delx R*8 (10) VAR COMMON 126 0 6-2D 6-4D e0za R*8 (9,15) VAR COMMON 128 0 9-2D 9-3D e1za R*8 (9,15,8) VAR COMMON 128 1080 9-2D 9-3D e2za R*8 (9,15,8) VAR COMMON 128 9720 9-2D 9-3D eiaz1 R*8 (15,8) VAR COMMON 117 360 2-2D 2-3D 2777 eiaz2 R*8 (15,8) VAR COMMON 117 1320 2-2D 2-3D 2778 eitl R*8 (15,8) VAR COMMON 188 0 10-2D 10-3D 2749 eitotz R*8 (15,8,11) VAR COMMON 444 21120 11-2D 11-3D 2751= 2752 eitr R*8 (15,8) VAR COMMON 188 960 10-2D 10-3D 2750 eittl R*8 (15,8,11) VAR COMMON 444 0 11-2D 11-3D 2749= 2751 2752 2754 eittr R*8 (15,8,11) VAR COMMON 444 10560 11-2D 11-3D 2750= 2751 2752 2754 eitu R*8 (15,8) VAR COMMON 188 1920 10-2D 10-3D 2752 eizero R*8 (15) VAR COMMON 117 240 2-2D 2-3D 2776 ematx R*8 (3,15) VAR COMMON 105 0 4-2D 4-4D emu R*8 (15) VAR COMMON 105 976 4-2D 4-4D emuz R*8 (10) VAR COMMON 105 1096 4-2D 4-4D fs R*8 VAR COMMON 117 2288 2-2D 2-3D 2706 2710 2712 2713 2714 gama R*8 VAR COMMON 70 8 7-3D 7-4D gg R*8 VAR COMMON 117 2280 2-2D 2-3D 2706 2712 2713 2714 ggz R*8 (9) VAR COMMON 128 18360 9-2D 9-3D 2710 gistl R*8 VAR AUTO 221 10856 2747= 2749 gistr R*8 VAR AUTO 221 10864 2748= 2750 hhold R*8 (101) VAR COMMON 85 1904 1-3D 1-5D i I*4 VAR AUTO 221 12 2702= 2706(2) 2720(2) 2722= 2727= 2731(3) 2732(2) 2740= 2744= 2747 2748 2749(2) 2750(2) 2751(3) 2752(5) 2754(4) 2763= 2774= 2775 2776 2777 2778 2782= iazmth I*4 VAR COMMON 85 12 1-2D 1-5D 2728 2745 imu I*4 VAR COMMON 85 4 1-2D 1-5D 2707 2727 2744 2774 imuz I*4 VAR COMMON 85 8 1-2D 1-5D ipath I*4 VAR COMMON 126 192 6-3D 6-4D ipol I*4 VAR COMMON 70 64 7-2D 7-4D ipsudo I*4 VAR COMMON 126 188 6-3D 6-4D it I*4 VAR AUTO 221 28 2709= 2710(3) 2711= itmax I*4 VAR COMMON 126 184 6-3D 6-4D 2700 itmaxp I*4 VAR AUTO 221 4 2700= 2701 j I*4 VAR AUTO 221 20 2707= 2710(3) 2712(3) 2713(3) 2714(3) 2715(3) 2720(3) 2721= 2728= 2731(2) 2732(2) 2739= 2745= 2749(2) 2750(2) 2751(3) 2752(5) 2754(4) 2762= k I*4 VAR AUTO 221 276 2729= 2731(2) 2732(2) 2738= 2746= 2747 2748 2749 2750 2751(3) 2752(4) 2754(4) 2761= lambda I*4 VAR COMMON 85 2800 1-2D 1-5D layer I*4 VAR COMMON 85 2804 1-2D 1-5D maxpp I*4 VAR AUTO 221 8 2701= 2709 nalb I*4 VAR COMMON 85 0 1-2D 1-5D 2702 2729 2746 pi R*8 VAR AUTO 221 10888 2768= 2775 2776 2777 2778 pnot R*8 VAR COMMON 87 24 5-2D 5-3D polz R*8 (15,8,11) VAR COMMON 444 31680 11-2D 11-3D 2752= 2754(2)= pshold R*8 (101) VAR COMMON 85 1096 1-3D 1-5D q R*8 VAR COMMON 70 16 7-3D 7-4D q1 R*8 VAR COMMON 70 24 7-3D 7-4D q12s R*8 VAR COMMON 70 56 7-3D 7-4D q2 R*8 VAR COMMON 70 32 7-3D 7-4D qr R*8 (11) VAR COMMON 117 32 2-2D 2-3D 2706 2747 2748 refdir R*8 (15) VAR COMMON 311 0 12-2D 12-3D 2710 2712 2713 2714 2720 rhon R*8 VAR COMMON 70 0 7-3D 7-4D ristar R*8 (15,11) VAR COMMON 435 0 3-2D 3-3D 2720= 2731 saz R*8 (8) VAR COMMON 105 720 4-2D 4-4D saz2 R*8 (8) VAR COMMON 105 848 4-2D 4-4D sb R*8 (4) VAR COMMON 117 0 2-2D 2-3D sbz R*8 (9) VAR COMMON 166 0 8-2D 8-3D sdp R*8 VAR COMMON 70 48 7-3D 7-4D tautot R*8 VAR COMMON 87 32 5-2D 5-3D temp R*8 (15) VAR AUTO 221 272 2695D 2715= tensig R*8 (11) VAR COMMON 435 1320 3-2D 3-3D 2706= 2720 tfunc R*8 VAR AUTO 221 10896 2775= thnot R*8 (10) VAR COMMON 85 2712 1-3D 1-5D thta R*8 (15) VAR COMMON 85 16 1-3D 1-5D tmp0 R*8 VAR COMMON 126 176 6-2D 6-4D tmp10 R*8 (10) VAR COMMON 126 88 6-2D 6-4D tmptop R*8 VAR COMMON 126 168 6-2D 6-4D tnstr R*8 (15) VAR COMMON 117 120 2-2D 2-3D 2712 2720 tnstrl R*8 (15) VAR COMMON 166 1152 8-2D 8-3D 2713 tnstrr R*8 (15) VAR COMMON 166 1272 8-2D 8-3D 2714 tnstrz R*8 (9,15) VAR COMMON 166 72 8-2D 8-3D 2710 total R*8 (15,8,11) VAR COMMON 435 1408 3-2D 3-3D 2731= 2732A totint R*8 (15,8) VAR COMMON 117 2296 2-2D 2-3D 2731 totn R*8 (15,8,11) VAR AUTO 221 10840 2694D 2732= tt R*8 (15) VAR AUTO 221 152 2693D 2712= 2775 ttlp R*8 (15) VAR COMMON 188 2880 10-2D 10-3D 2713= 2715 2747 ttrp R*8 (15) VAR COMMON 188 3000 10-2D 10-3D 2714= 2715 2748 ttz R*8 (9,15) VAR COMMON 444 42240 11-2D 11-3D 2710= wavelen R*8 VAR COMMON 87 40 5-2D 5-3D x R*8 (101) VAR COMMON 85 288 1-3D 1-5D xi1 R*8 VAR AUTO 221 10912 2777= xi2 R*8 VAR AUTO 221 10920 2778= xizero R*8 VAR AUTO 221 10904 2776= xtop R*8 VAR COMMON 126 80 6-2D 6-4D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 2722 124 2711 133 2781 135 2764 300 2738 500 2740 123 2717 132 2772 134 2784 200 2721 400 2739 666 2736 0002788 subroutine itrate(z,ncp1,itmax,jmuz) 0002789 c 0002790 c********************************************************************** 0002791 cccc 0002792 c version aug 22,1977 0002793 c 0002794 c purpose 0002795 c 0002796 c itrate is a fortran iv routine which performs the iterations 0002797 c of the dave z matrix. 0002798 c 0002799 c method 0002800 c 0002801 c using the zeroth order approx for the z matrices from firstz 0002802 c itrate iterates the z matrix for itmax times and saves the 0002803 c last three iterated z values for each layer. 0002804 c in addition the last three computed values of exponential 0002805 c summations needed by evaltit are also saved. 0002806 c 0002807 c calling sequence 0002808 c 0002809 c call itrate (qr,z,tnstr,fs,ncp1,itmax,jmuz) 0002810 c 0002811 c variable type i/o description 0002812 c -------- ---- --- ----------- 0002813 c 0002814 c qr(10) r*8 i factor used in computing ig 0002815 c z(202) r*8 i zeroth order approx for z matrix 0002816 c calculated by firstz 0002817 c tnstr(15) r*8 o 0002818 c 0002819 c fs r*8 0002820 c ncp1 i*4 i # layers +1 0002821 c itmax i*4 i max # iterations 0002822 c jmuz i*4 i index specifying present value of 0002823 c solar zenith angle 0002824 c 0002825 c external references 0002826 c evalit 0002827 c 0002828 c common areas referenced 0002829 c 0002830 c analysis and programming 0002831 c k.f. klenk 0002832 c k.f. klenk,p.m. smith sasc, aug 22 1977 0002833 c 0002834 c modifications (date name purpose) 0002835 c 0002836 c last modified 11/19/92 by zia ahmad 0002837 c modified for single iteration 0002838 c 0002839 c last modified 10/19/94 by zia ahmad 0002840 c modified to print results after each itration 0002841 c 0002842 c last modified 03/08/95 by dave flittner 0002843 c modified to call eva1pol after each iteration if switch 0002844 c write_iter_file is TRUE 0002845 c 0002846 c last modified 03/14/95...dave flittner 0002847 c purpose: set pressure scale height used in gravity correction 0002848 c to rayleigh scattering od. Create new variable pscaleforg and 0002849 c pass in common block consts. 0002850 cccc 0002851 c*********************************************************************** 0002852 c 0002853 implicit integer*4(i-n),real*8(a-h,o-z) 0002854 c 0002855 real*8 z(202),z1(202),z2(202),z3(202),z4(202), 0002856 1 zj1(202),zj2(202),b1(202),b2(202),b3(202),b4(202), 0002857 2 bj1(202),bj2(202),ekary(202,5),zma1(4,202), 0002858 3 zma2(4,202),zma3(4,202),zma4(4,202),ej1(4,202),ej2(4,202) 0002859 c 0002860 real*8 tm1(4,202),tm2(4,202),tm3(4,202),tm4(4,202), 0002861 1 tm5(4,202),tm6(4,202) 0002862 c 0002863 include "cwrite_iter.inc" 0002864 include "prints.inc" 0002865 include "kmat.inc" 0002866 include "consts.inc" 0002867 c 0002868 itmm2=itmax-2 0002869 index=1 0002870 itmaxp=itmax+1 0002871 c 0002872 c construct zeroth z- matrix and reduced source functions for 0002873 c azimuth dependent terms 0002874 c 0002875 do 250 i=1,ncp1 0002876 z1(i)=z(i) 0002877 z2(i)=0.d0 0002878 z3(i)=0.d0 0002879 z4(i)=z(i) 0002880 zj1(i)=z(i) 0002881 zj2(i)=z(i) 0002882 tm1(1,i)=z1(i) 0002883 tm2(1,i)=z2(i) 0002884 tm3(1,i)=z3(i) 0002885 tm4(1,i)=z4(i) 0002886 tm5(1,i)=zj1(i) 0002887 tm6(1,i)=zj2(i) 0002888 250 continue 0002889 c 0002890 if(write_iter_file.or.jprint(4).eq.1) !def 0002891 & call eva1pol(tm1,tm2,tm3,tm4,tm5,tm6,jmuz,ncp1,1) 0002892 c 0002893 if (itmax.eq.1) then 0002894 do 255 i = 1,ncp1 0002895 zma1(index,i) = z1(i) 0002896 zma2(index,i) = z2(i) 0002897 zma3(index,i) = z3(i) 0002898 zma4(index,i) = z4(i) 0002899 ej1(index,i) = z(i) 0002900 ej2(index,i) = z(i) 0002901 255 continue 0002902 goto 101 0002903 endif 0002904 do 140 it=1,itmax 0002905 do 145 m=1,ncp1 0002906 b1(m)=z1(m) 0002907 b2(m)=z2(m) 0002908 b3(m)=z3(m) 0002909 b4(m)=z4(m) 0002910 bj1(m)=zj1(m) 0002911 bj2(m)=zj2(m) 0002912 145 continue 0002913 c 0002914 c do first and higher order iterations 0002915 c 0002916 do 410 i=1,ncp1 0002917 do 5100 kk = 1,202 0002918 do 5101 kkk = 1,5 0002919 ekary(kk,kkk) = nek(kk,kkk,i) 0002920 5101 continue 0002921 5100 continue 0002922 azsum=z(i) 0002923 bzsum=0.0d0 0002924 czsum=0.0d0 0002925 dzsum=z(i) 0002926 ejsum=z(i) 0002927 fjsum=z(i) 0002928 c 0002929 do 290 j=1,ncp1 0002930 azsum=azsum+ekary(j,1)*b1(j)+ekary(j,2)*b3(j) 0002931 bzsum=bzsum+ekary(j,1)*b2(j)+ekary(j,2)*b4(j) 0002932 czsum=czsum+ekary(j,2)*b1(j)+ekary(j,3)*b3(j) 0002933 dzsum=dzsum+ekary(j,2)*b2(j)+ekary(j,3)*b4(j) 0002934 ejsum=ejsum+ekary(j,4)*bj1(j) 0002935 fjsum=fjsum+ekary(j,5)*bj2(j) 0002936 290 continue 0002937 c 0002938 z1(i)=azsum 0002939 z2(i)=bzsum 0002940 z3(i)=czsum 0002941 z4(i)=dzsum 0002942 zj1(i)=ejsum 0002943 zj2(i)=fjsum 0002944 c 0002945 c 0002946 tm1(1,i)=z1(i) 0002947 tm2(1,i)=z2(i) 0002948 tm3(1,i)=z3(i) 0002949 tm4(1,i)=z4(i) 0002950 tm5(1,i)=zj1(i) 0002951 tm6(1,i)=zj2(i) 0002952 c save z matrix and zj1,zj2 of last three iterations 0002953 c 0002954 if(it.lt.itmm2) go to 410 0002955 c 0002956 c 0002957 zma1(index,i)=z1(i) 0002958 zma2(index,i)=z2(i) 0002959 zma3(index,i)=z3(i) 0002960 zma4(index,i)=z4(i) 0002961 ej1(index,i)=zj1(i) 0002962 ej2(index,i)=zj2(i) 0002963 410 continue 0002964 itp=it+1 0002965 if((itp .le. itmaxp).and. !def 0002966 &(write_iter_file.or.(jprint(4).eq.1)))then !def 0002967 call eva1pol(tm1,tm2,tm3,tm4,tm5,tm6,jmuz,ncp1,itp) 0002968 endif 0002969 if(it.ge.itmm2) index=index+1 0002970 140 continue 0002971 index=index-1 0002972 101 continue 0002973 if(jprint(4).eq.1) write(33,1000) 0002974 1 (i,zma1(index,i),zma2(index,i),zma3(index,i),zma4(index,i), 0002975 2 ej1(index,i),ej2(index,i),i=1,ncp1) 0002976 0002977 c -- call evalit to calculate the radiance at the top of the 0002978 c -- atmosphere and the downward diffuse flux at the ground 0002979 c 0002980 itpp=itp+1 0002981 if(write_iter_file.or.(jprint(4).eq.1)) !def 0002982 & call eva1pol(zma1,zma2,zma3,zma4,ej1,ej2,jmuz,ncp1,itpp) 0002983 call evalit (zma1,zma2,zma3,zma4,ej1,ej2,jmuz,ncp1) 0002984 if(jprint(4).eq.1) write(33,2000) 0002985 1 (i,zma1(4,i),zma2(4,i),zma3(4,i),zma4(4,i), 0002986 2 ej1(4,i),ej2(4,i),i=1,ncp1) 0002987 return 0002988 1000 format(1h1,t30,'debug print out from itrate ',10x, 0002989 1 'zmatrix after final iteration',////, 0002990 2 1h ,1x,' i',4x,'zma1',10x,'zma2',10x,'zma3',10x,'zma4', 0002991 3 10x,'ej1',11x,'ej2',4x,///,(1x,i3,1x,d12.6,2x,d12.6, 0002992 4 2x,d12.6,2x,d12.6,2x,d12.6,2x,d12.6)) 0002993 2000 format(///,1x,'source functions after extrapolation',//, 0002994 2 1h ,1x,' i',4x,'zma1',10x,'zma2',10x,'zma3',10x,'zma4', 0002995 3 10x,'ej1',11x,'ej2',4x,///,(1x,i3,1x,d12.6,2x,d12.6, 0002996 4 2x,d12.6,2x,d12.6,2x,d12.6,2x,d12.6)) 0002997 end INCLUDE FILES FileNo File name 1 cwrite_iter.inc 2 prints.inc 3 kmat.inc 4 consts.inc ENTRY POINTS Name Type BlockNo itrate SUBR 460 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References eva1pol SUBR EXTERNAL 2890 2967 2981 evalit SUBR EXTERNAL 2983 itrate SUBR 2788D COMMON BLOCKS Name Size BlockNo consts_ 112 66 cwrite_iter_ 4 462 kmat_ 1632160 263 prints_ 40 124 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References azsum R*8 VAR AUTO 460 105096 2922= 2930(2)= 2938 b1 R*8 (202) VAR AUTO 460 88920 2855D 2906= 2930 2932 b2 R*8 (202) VAR AUTO 460 90536 2855D 2907= 2931 2933 b3 R*8 (202) VAR AUTO 460 92152 2855D 2908= 2930 2932 b4 R*8 (202) VAR AUTO 460 93768 2855D 2909= 2931 2933 bj1 R*8 (202) VAR AUTO 460 95384 2855D 2910= 2934 bj2 R*8 (202) VAR AUTO 460 97000 2855D 2911= 2935 bzsum R*8 VAR AUTO 460 105104 2923= 2931(2)= 2939 c1415 R*8 VAR COMMON 66 72 4-2D 4-4D c215 R*8 VAR COMMON 66 48 4-2D 4-4D c2815 R*8 VAR COMMON 66 80 4-2D 4-4D c38sq2 R*8 VAR COMMON 66 64 4-2D 4-4D c815 R*8 VAR COMMON 66 56 4-2D 4-4D cnvrt R*8 VAR COMMON 66 8 4-2D 4-4D cons R*8 VAR COMMON 66 32 4-2D 4-4D czsum R*8 VAR AUTO 460 105112 2924= 2932(2)= 2940 dzsum R*8 VAR AUTO 460 105120 2925= 2933(2)= 2941 ej1 R*8 (4,202) VAR AUTO 460 80824 2855D 2899= 2961= 2973 2981A 2983A 2984 ej2 R*8 (4,202) VAR AUTO 460 87288 2855D 2900= 2962= 2973 2981A 2983A 2984 ejsum R*8 VAR AUTO 460 105128 2926= 2934(2)= 2942 ekary R*8 (202,5) VAR AUTO 460 105088 2855D 2919= 2930(2) 2931(2) 2932(2) 2933(2) 2934 2935 fjsum R*8 VAR AUTO 460 105136 2927= 2935(2)= 2943 i I*4 VAR AUTO 460 16 2875= 2876(2) 2877 2878 2879(2) 2880(2) 2881(2) 2882(2) 2883(2) 2884(2) 2885(2) 2886(2) 2887(2) 2888= 2894= 2895(2) 2896(2) 2897(2) 2898(2) 2899(2) 2900(2) 2901= 2916= 2919 2922 2925 2926 2927 2938 2939 2940 2941 2942 2943 2946(2) 2947(2) 2948(2) 2949(2) 2950(2) 2951(2) 2957(2) 2958(2) 2959(2) 2960(2) 2961(2) 2962(2) 2963= 2973(9)= 2984(9)= index I*4 VAR AUTO 460 8 2869= 2895 2896 2897 2898 2899 2900 2957 2958 2959 2960 2961 2962 2969(2)= 2971(2)= 2973(6) it I*4 VAR AUTO 460 87292 2904= 2954 2964 2969 2970= itmax I*4 VAR ARG 2788D 2868 2870 2893 2904 itmaxp I*4 VAR AUTO 460 12 2870= 2965 itmm2 I*4 VAR AUTO 460 4 2868= 2954 2969 itp I*4 VAR AUTO 460 105148 2964= 2965 2967A 2980 itpp I*4 VAR AUTO 460 105152 2980= 2981A j I*4 VAR AUTO 460 105140 2929= 2930(4) 2931(4) 2932(4) 2933(4) 2934(2) 2935(2) 2936= jmuz I*4 VAR ARG 2788D 2890A 2967A 2981A 2983A jprint I*4 (10) VAR COMMON 124 0 2-2D 2-3D 2890 2965 2973 2981 2984 kk I*4 VAR AUTO 460 97004 2917= 2919(2) 2921= kkk I*4 VAR AUTO 460 97008 2918= 2919(2) 2920= kskip R*8 VAR COMMON 66 104 4-2D 4-4D m I*4 VAR AUTO 460 87296 2905= 2906(2) 2907(2) 2908(2) 2909(2) 2910(2) 2911(2) 2912= ncp1 I*4 VAR ARG 2788D 2875 2890A 2894 2905 2916 2929 2967A 2973 2981A 2983A 2984 nek R*8 (202,5,202) VAR COMMON 263 0 3-2D 3-3D 2919 numek R*8 VAR COMMON 66 96 4-2D 4-4D pi R*8 VAR COMMON 66 0 4-2D 4-4D pscaleforg R*8 VAR COMMON 66 88 4-2D 4-4D r R*8 VAR COMMON 66 16 4-2D 4-4D rinv R*8 VAR COMMON 66 24 4-2D 4-4D sq2 R*8 VAR COMMON 66 40 4-2D 4-4D tm1 R*8 (4,202) VAR AUTO 460 16184 2860D 2882= 2890A 2946= 2967A tm2 R*8 (4,202) VAR AUTO 460 22648 2860D 2883= 2890A 2947= 2967A tm3 R*8 (4,202) VAR AUTO 460 29112 2860D 2884= 2890A 2948= 2967A tm4 R*8 (4,202) VAR AUTO 460 35576 2860D 2885= 2890A 2949= 2967A tm5 R*8 (4,202) VAR AUTO 460 42040 2860D 2886= 2890A 2950= 2967A tm6 R*8 (4,202) VAR AUTO 460 48504 2860D 2887= 2890A 2951= 2967A write_iter_file L*4 VAR COMMON 462 0 1-2D 1-3D 2890 2965 2981 z R*8 (202) VAR ARG 2788D 2855D 2876 2879 2880 2881 2899 2900 2922 2925 2926 2927 z1 R*8 (202) VAR AUTO 460 1640 2855D 2876= 2882 2895 2906 2938= 2946 2957 z2 R*8 (202) VAR AUTO 460 3256 2855D 2877= 2883 2896 2907 2939= 2947 2958 z3 R*8 (202) VAR AUTO 460 4872 2855D 2878= 2884 2897 2908 2940= 2948 2959 z4 R*8 (202) VAR AUTO 460 6488 2855D 2879= 2885 2898 2909 2941= 2949 2960 zj1 R*8 (202) VAR AUTO 460 8104 2855D 2880= 2886 2910 2942= 2950 2961 zj2 R*8 (202) VAR AUTO 460 9720 2855D 2881= 2887 2911 2943= 2951 2962 zma1 R*8 (4,202) VAR AUTO 460 54968 2855D 2895= 2957= 2973 2981A 2983A 2984 zma2 R*8 (4,202) VAR AUTO 460 61432 2855D 2896= 2958= 2973 2981A 2983A 2984 zma3 R*8 (4,202) VAR AUTO 460 67896 2855D 2897= 2959= 2973 2981A 2983A 2984 zma4 R*8 (4,202) VAR AUTO 460 74360 2855D 2898= 2960= 2973 2981A 2983A 2984 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 101 2972 145 2912 255 2901 410 2963 2000 2993 5101 2920 140 2970 250 2888 290 2936 1000 2988 5100 2921 0002998 subroutine matmul(x,y,z) 0002999 real*8 x(4),y(4),z(4) 0003000 c 0003001 c 0003002 z(1)=x(1)*y(1)+x(2)*y(3) 0003003 z(2)=x(1)*y(2)+x(2)*y(4) 0003004 z(3)=x(3)*y(1)+x(4)*y(3) 0003005 z(4)=x(3)*y(2)+x(4)*y(4) 0003006 c 0003007 return 0003008 end ENTRY POINTS Name Type BlockNo matmul SUBR 138 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References matmul SUBR 2998D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References x R*8 (4) VAR ARG 2998D 2999D 3002(2) 3003(2) 3004(2) 3005(2) y R*8 (4) VAR ARG 2998D 2999D 3002(2) 3003(2) 3004(2) 3005(2) z R*8 (4) VAR ARG 2998D 2999D 3002= 3003= 3004= 3005= 0003009 program matscn 0003010 c author: c. seftor 0003011 c date: 12-mar-1992 0003012 c last modified 9/22/93 .... zia ahmad 0003013 c purpose: to include the effect of molecular anisotropy in 0003014 c rayleigh phase function 0003015 c 0003016 c purpose: used in conjunction with the mateer scan code to 0003017 c generate radiance tables for a given ozone profile 0003018 c and for given scan and azimuth angles (modified from 0003019 c profil). 0003020 c 0003021 c last modified 03/07/95... dave flittner 0003022 c purpose: compute spherical correction to the out going beam 0003023 c when integrating after iteration process. Set with lsphout 0003024 c logical variable. 0003025 c 0003026 c last modified 03/08/95... dave flittner 0003027 c purpose: store Z1=I1/(-3/8*muo*sqrt(1-muo^2)*sqrt(1-mu^2)) and 0003028 c Z2=I2/(3/32*(1-muo^2)*(1-mu^2)/mu) so can be used as input into 0003029 c interpolation tables. 0003030 c 0003031 c last modified 03/14/95...dave flittner 0003032 c purpose: set pressure scale height used in gravity correction 0003033 c to rayleigh scattering od. Create new variable pscaleforg and 0003034 c pass in common block consts. Also use logical switch lgcorrect 0003035 c to impliment the gravity correction to the rayleigh scattering 0003036 c optical depth. 0003037 c 0003038 implicit integer*4(i-n), real*8(a-h,o-z) 0003039 integer*4 max_wave, max_scan, max_sza 0003040 parameter (max_wave = 2500, max_scan = 6, max_sza = 10) 0003041 integer*4 nwavl, layr 0003042 C 0003043 C Setting up virtual memory for output parameters 0003044 C 0003045 real*8 wavel (max_wave) 0003046 real*8 i0_out(max_scan, max_sza, max_wave) 0003047 real*8 Z1_out(max_scan, max_sza, max_wave) 0003048 real*8 Z2_out(max_scan, max_sza, max_wave) 0003049 real*8 t_out(max_scan, max_sza, max_wave) 0003050 real*8 sb_out(max_wave) 0003051 C 0003052 C Local Variables 0003053 C 0003054 real*8 p(101),t(101),tl(101),z(202) 0003055 real*8 sbt 0003056 real*8 tmp101(101), tmpcf(2) 0003057 real*8 cofx(4,487),h(487),ps(487) 0003058 real*8 tr, tensit 0003059 real*8 alphp(12), betp(12), xsav(11), xdel 0003060 real*8 psza(10) 0003061 character file_name*200 0003062 C 0003063 C Functions 0003064 C 0003065 logical get_coef 0003066 C 0003067 C Common 0003068 C 0003069 include "cwrite_iter.inc" 0003070 include "emm.inc" 0003071 include "kmat.inc" 0003072 include "log.inc" 0003073 include "consts.inc" 0003074 include "thkns.inc" 0003075 include "atmos.inc" 0003076 include "input.inc" 0003077 include "inchr.inc" 0003078 include "in.inc" 0003079 include "contrl.inc" 0003080 include "out.inc" 0003081 include "totals.inc" 0003082 include "prints.inc" 0003083 include "buff1.inc" 0003084 include "buff2.inc" 0003085 include "buff3.inc" 0003086 include "buff4.inc" 0003087 include "csphout.inc" 0003088 include "cgcorrect.inc" 0003089 include "crefdir.inc" 0003090 include "czfunc.inc" 0003091 include "depolt.inc" 0003092 c 0003093 c if lsphout = True, then perform the out going beam using 0003094 c spherical geometry. If False, then use flat atmosphere. 0003095 c 0003096 data lsphout/.TRUE./ 0003097 c 0003098 c if lgcorrect = True, then perform the gravity correciton to the 0003099 c rayleigh scattering optical depth. 0003100 c 0003101 data lgcorrect/.TRUE./ 0003102 c 0003103 xdel = 0.0 0003104 jjprint = 0 0003105 c 0003106 c --read in all input values 0003107 c 0003108 call iniclz 0003109 call readin 0003110 c 0003111 num_arg = iargc() 0003112 if (num_arg .lt. 4) then 0003113 file_name = 'profil.dat' 0003114 else 0003115 call getarg(4, file_name) 0003116 end if 0003117 if (jprint(10).eq.1) 0003118 1 open (unit=23,file=file_name,recl=160,status='unknown') 0003119 if (num_arg .lt. 3) then 0003120 file_name = '/dev/null' 0003121 else 0003122 call getarg(3, file_name) 0003123 end if 0003124 open (unit=33,file=file_name,recl=132,status='unknown') 0003125 if (num_arg .lt. 5) then 0003126 file_name = 'sumry.dat' 0003127 else 0003128 call getarg(5, file_name) 0003129 end if 0003130 if (jprint(10).eq.1) 0003131 1 open (unit=9,file=file_name,status='unknown') 0003132 write_iter_file = num_arg .gt. 5 0003133 if (write_iter_file) then 0003134 call get_lun(iter_lun) 0003135 call getarg(6, file_name) 0003136 open (iter_lun, file=file_name, status='unknown', 0003137 * form='unformatted') 0003138 end if 0003139 c 0003140 c Make sure storage buffers do not overflow 0003141 c 0003142 if (max_scan .lt. imu) then 0003143 print*,'Too many scan angles to store. Max num of scan angles' 0003144 print*,'is limited to ',max_scan,' and ',imu,' were requested.' 0003145 write(0, '(''Too many ssan angles to process'')') 0003146 end if 0003147 0003148 if (max_sza .lt. nthet) then 0003149 print*,'Too many solar zenith angles to store. Max num of SZA' 0003150 print*,'is limited to ',max_sza,' and ',nthet,' were requested.' 0003151 write(0, '(''Too many scan angles to process'')') 0003152 end if 0003153 c 0003154 jjprint = jprint(1) + jprint(2) + jprint(3) + jprint(4) 0003155 1 + jprint(5) + jprint(6) + jprint(7) + jprint(8) 0003156 len = index(prfnam,' ') + 1 0003157 c 0003158 c open (unit=34,file=prfnam(1:1)//prfnam(len:len+2)//'.OUT', 0003159 c 1 form='unformatted',status='unknown') 0003160 c 0003161 c open (unit=35,file='TOM2.OUT',form='unformatted', 0003162 c 1 status='unknown') 0003163 c 0003164 c 0003165 if (jprint(10).eq.1) then 0003166 write (23,6400) prfnam(1:8) 0003167 write (23,6450) 0003168 write (23,6475) pres 0003169 write (23,6490) nthet 0003170 write (23,6492) nscan 0003171 write (23,6493) iazmth 0003172 write (23,6494) nalb 0003173 write (23,6496) start_wave, end_wave 0003174 write (23,6497) 0003175 write (23,6498) (jprint(j),j=1,8) 0003176 write (23,6500) (j,j=1,11) 0003177 write (23,6600) xprf 0003178 write (23,6700) tmpprf 0003179 write (23,6725) (j,j=1,10) 0003180 write (23,6750) (theta(j),j=1,10) 0003181 write (23,6751) (scan(j),j=1,nscan) 0003182 write (23,6752) (azmth(j),j=1,iazmth) 0003183 write (23,6753) (alb(j),j=1,nalb) 0003184 endif 0003185 call ctol(lwav) 0003186 tmp0 = 273. 0003187 pnot = pres 0003188 ipath = 0 0003189 ipsudo = 1 0003190 jw = 0 0003191 iter_pos = 1 0003192 c --loop over all wavelengths 0003193 num = 0 0003194 do while (get_coef(start_wave, end_wave, wavelen, alpha0, 0003195 * tmpcf(1), tmpcf(2), beta, rhon) .and. num .lt. max_wave) 0003196 if (alpha0 .eq. 0.0) alpha0 = 1.0d-10 0003197 num = num + 1 0003198 wavel(num) = wavelen 0003199 if (jjprint.ne.0) write (33,7902) wavel(num) 0003200 lambda = wavelen 0003201 if (jprint(9).eq.1) write (6,6200) wavelen 0003202 do while (iter_pos .lt. num_iter .and. 0003203 * wave_iter(iter_pos+1) .lt. wavelen) 0003204 iter_pos = iter_pos + 1 0003205 end do 0003206 itmax = iter(iter_pos) 0003207 c new statements 0003208 if (jjprint .ne. 0) write(33,2121) wavelen 0003209 2121 format('matscn wavelength', 1pe12.4) 0003210 call iniclz1 0003211 call emmat(imu,imuz,iazmth,thnot,thta,azmth) 0003212 c end of new statements 0003213 call relayr(xprf(2),xprf(1),tmpprf(2),tmpprf(1),x, 0003214 1 tmp101,pnot,xpnot,hhold,pshold) 0003215 call opthik(x,p,t,tl,cofx,tmp0,tmpcf,tmp101) 0003216 call dtaus(cofx,nc,xpnot,ncp1) 0003217 c change the order of the subroutines, placing the call to slant after 0003218 c dtaus instead of after reflex. !def 0003219 lmax=82 0003220 layer=6 0003221 call slant(h,ps,cofx,fracin,lmax,layer,pshold,hhold) 0003222 if(lsphout)then !def 0003223 call exponesph(h,ps,cofx,lmax,nc,ncp1,imu) !def 0003224 else !def 0003225 do j=1,imu !def 0003226 refdir(j)=0.0d0 !def 0003227 if(emu(j).ne.0.d0) refdir(j)=dexp(-tautot/emu(j)) !def 0003228 enddo !def 0003229 call expone(nc,ncp1,imu) !def 0003230 endif !def 0003231 c --compute effective alpha 0003232 call reflex(itmax,nek,ncp1) 0003233 js = 0 0003234 do 2000 ijk=1,nthet 0003235 js = js + 1 0003236 if (jprint(9).eq.1) write (6,6300) theta(ijk) 0003237 psza(js) = theta(ijk) 0003238 thenot=theta(ijk) 0003239 cos_theta = cosd(theta(ijk)) 0003240 cos_sin_theta = cos_theta*sind(theta(ijk)) 0003241 if(ipath.eq.1) then 0003242 thenot=dsqrt(1.d0-(1.d0/theta(ijk))**2)/cons 0003243 thenot=dasin(thenot)/cnvrt 0003244 endif 0003245 if (ipsudo.eq.1) then 0003246 call firstz(h,ps,z,thenot,fracin,lmax,ncp1) 0003247 else 0003248 call frstz2(z,thenot,fs,f1,f2,ncp1) 0003249 endif 0003250 call itrate(z,ncp1,itmax,ijk) 0003251 C 0003252 C Storing output parameters 0003253 C 0003254 do j = 1, imu 0003255 0003256 i0_out(j, ijk, num) = eizero(j) 0003257 sin_view = sind(scan(j)) 0003258 cos_view = cosd(scan(j)) 0003259 Z1_out(j, ijk, num) = Z1func(j) !def 0003260 Z2_out(j, ijk, num) = Z2func(j) !def 0003261 t_out(j, ijk, num) = (fs+gg)*(tnstr(j)+refdir(j)) !def 0003262 if (write_iter_file) 0003263 * write (iter_lun) wavelen, theta(ijk), scan(j), 0003264 * i0_out(j, ijk, num)/pi, Z1_out(j, ijk, num)/pi, 0003265 * Z2_out(j, ijk, num)/pi, t_out(j, ijk, num)/pi, 0003266 * sb(4), itmax + 2, 0003267 * (tnstrz(iter_num, j), iter_num = 1, itmax+2), 0003268 * (e0za(iter_num, j), iter_num = 1, itmax+2), 0003269 * (ggz(iter_num), iter_num = 1, itmax+2), 0003270 * (sbz(iter_num), iter_num = 1, itmax+2), 0003271 * fs, gg, exp(-tautot), iazmth, nalb, 0003272 * (eitl(j, iaz), iaz = 1, iazmth), 0003273 * (eitr(j, iaz), iaz = 1, iazmth), 0003274 * (eitu(j, iaz), iaz = 1, iazmth), 0003275 * ttlp(j), ttrp(j) 0003276 end do 0003277 if (jprint(8).eq.1) call tbprnt(thenot) 0003278 2000 continue 0003279 sb_out(num) = sb(4) 0003280 end do 0003281 C 0003282 C Issue a warning message if there was an attempt to do too many wavelengths 0003283 C 0003284 if (num .eq. max_wave) then 0003285 print*,'Too many wavelenghts were being requested.' 0003286 print*,'Maximun number of wavelengths is current set to ', 0003287 * max_wave 0003288 end if 0003289 c 0003290 c 0003291 c 0003292 nwavl = num 0003293 if (num_arg .lt. 2) then 0003294 file_name = 'tomnval.dat' 0003295 else 0003296 call getarg(2, file_name) 0003297 end if 0003298 if (jprint(10).eq.1) then 0003299 open(unit=40, file=file_name ,form='unformatted', 0003300 * status='unknown') 0003301 write (40) nscan, nthet, nwavl 0003302 write (40) (wavel(i), i = 1, nwavl) 0003303 write (40) (((i0_out(i, j, k), k=1,nwavl), j = 1, nthet), 0003304 * i=1, nscan) 0003305 write (40) (((Z1_out(i, j, k), k=1,nwavl), j = 1, nthet), 0003306 * i=1, nscan) 0003307 write (40) (((Z2_out(i, j, k), k=1,nwavl), j = 1, nthet), 0003308 * i=1, nscan) 0003309 write (40) (((t_out(i, j, k), k=1,nwavl), j = 1, nthet), 0003310 * i=1, nscan) 0003311 write (40) (sb_out(j), j = 1, nwavl) 0003312 endif 0003313 C 0003314 C Output stuff here 0003315 C 0003316 c 0003317 901 format(f4.1,1x,f5.1,1x,10(f7.2,1x)) 0003318 if (write_iter_file) close(iter_lun) 0003319 close (40) 0003320 close (23) 0003321 close (33) 0003322 c close (34) 0003323 6200 format(' now doing calc for wavelength ',f7.2) 0003324 6300 format(' now doing calc for sza ',f7.2) 0003325 6400 format(' ***** ',a8,' *****') 0003326 6450 format(//,' ***** input *****') 0003327 6475 format(//,' pres....',f4.2) 0003328 6490 format(' nthet...',i4) 0003329 6492 format(' nscan...',i4) 0003330 6493 format(' nazim...',i4) 0003331 6494 format(' nalb....',i4) 0003332 6496 format(' wavelength range...',f8.2,' to ',f8.2) 0003333 6497 format(' evalit',' evalrf',' expone',' itrate',' opthik', 0003334 1 ' relayr',' slant',' tbprnt') 0003335 6498 format(i5,7i7) 0003336 6500 format(/,' sbuv layr',t10,11i7) 0003337 6550 format(//,'dndw tables for layer',i3,/) 0003338 6600 format(' ozone amt',t12,11f7.2) 0003339 6700 format(' layer tmp',t12,11f7.2) 0003340 6725 format(/,' sza #',t10,10i7) 0003341 6750 format(' sza',t12,10f7.2) 0003342 6751 format(' scan angles',t12,15f7.2) 0003343 6752 format(' azm angles',t12,8f7.2) 0003344 6753 format(' albedos ',t12,8f7.2) 0003345 6775 format(/,' wavl #',t13,i7,11i12) 0003346 7000 format(' wavelen',t11,12f12.3) 0003347 7100 format(/,' alpha0',t12,12d12.5) 0003348 7200 format(' beta',t12,12d12.5) 0003349 7300 format(' tmpcof(1)',t12,12d12.5) 0003350 7400 format(' tmpcof(2)',t12,12d12.5) 0003351 7425 format(' niter',t12,i7,11i12) 0003352 7450 format(//,' ***** output *****') 0003353 7700 format(f7.3,t12,12d12.5) 0003354 7850 format(' sza') 0003355 7800 format(//,'n values for alb of ',f6.2) 0003356 7801 format(' scn of ',f6.2,' azm of ',f6.2, 0003357 1//,' wvl',t11,12f12.3) 0003358 7900 format(//,'dndw values for alb of ',f6.2) 0003359 7901 format(' scn of ',f6.2,' azm of ',f6.2, 0003360 1//,' wvl',t11,12f12.3) 0003361 7902 format(//,' ***** Output for wavelength ',f7.2,' *****',//) 0003362 end INCLUDE FILES FileNo File name 1 cwrite_iter.inc 2 emm.inc 3 kmat.inc 4 log.inc 5 consts.inc 6 thkns.inc 7 atmos.inc 8 input.inc 9 inchr.inc 10 in.inc 11 contrl.inc 12 out.inc 13 totals.inc 14 prints.inc 15 buff1.inc 16 buff2.inc 17 buff3.inc 18 buff4.inc 19 csphout.inc 20 cgcorrect.inc 21 crefdir.inc 22 czfunc.inc 23 depolt.inc ENTRY POINTS Name Type BlockNo MAIN_ 483 matscn 482 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References MAIN_ 3009D __set_f77vms_flag SUBR EXTERNAL 3362 cosd INTRINSIC 3239 3258 ctol SUBR EXTERNAL 3185 dasin INTRINSIC 3243 dexp INTRINSIC 3227 dsqrt INTRINSIC 3242 dtaus SUBR EXTERNAL 3216 emmat SUBR EXTERNAL 3211 exp INTRINSIC 3262 expone SUBR EXTERNAL 3229 exponesph SUBR EXTERNAL 3223 firstz SUBR EXTERNAL 3246 frstz2 SUBR EXTERNAL 3248 get_coef L*4 EXTERNAL 3065D 3194 3280 get_lun SUBR EXTERNAL 3134 getarg SUBR EXTERNAL 3115 3122 3128 3135 3296 iargc I*4 EXTERNAL 3111 index INTRINSIC 3156 iniclz SUBR EXTERNAL 3108 iniclz1 SUBR EXTERNAL 3210 itrate SUBR EXTERNAL 3250 matscn 3009D opthik SUBR EXTERNAL 3215 readin SUBR EXTERNAL 3109 reflex SUBR EXTERNAL 3232 relayr SUBR EXTERNAL 3213 sind INTRINSIC 3240 3257 slant SUBR EXTERNAL 3221 tbprnt SUBR EXTERNAL 3277 COMMON BLOCKS Name Size BlockNo atmos_ 48 87 buff1_ 1392 166 buff2_ 18432 128 buff3_ 3120 188 buff4_ 43320 444 cgcorrect_ 4 92 consts_ 112 66 contrl_ 2808 85 crefdir_ 120 311 csphout_ 4 303 cwrite_iter_ 4 462 czfunc_ 240 190 depolt_ 68 70 emm_ 1176 105 in_ 196 126 inchr_ 35 11 input_ 556 493 kmat_ 1632160 263 log_ 48 488 out_ 3256 117 prints_ 40 124 thkns_ 8888 83 totals_ 11968 435 PARAMETERS Name Type References max_num_iter I*4 8-2D 8-3 8-4 max_scan I*4 3039D 3040D 3046 3047 3048 3049 3142 3144 max_sza I*4 3039D 3040D 3046 3047 3048 3049 3148 3150 max_wave I*4 3039D 3040D 3045 3046 3047 3048 3049 3050 3194 3284 3286 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 2-2D 2-4D alb R*8 (11) VAR COMMON 85 200 11-3D 11-5D 3183 alfaef R*8 VAR COMMON 85 2792 11-5D alpha0 R*8 VAR COMMON 87 0 7-2D 7-3D 3194A 3196(2)= 3280A alphp R*8 (12) VAR 3059D Variable declared and not used azmth R*8 (8) VAR COMMON 85 136 11-3D 11-5D 3182 3211A beta R*8 VAR COMMON 87 8 7-2D 7-3D 3194A 3280A betp R*8 (12) VAR 3059D Variable declared and not used c1415 R*8 VAR COMMON 66 72 5-2D 5-4D c215 R*8 VAR COMMON 66 48 5-2D 5-4D c2815 R*8 VAR COMMON 66 80 5-2D 5-4D c38sq2 R*8 VAR COMMON 66 64 5-2D 5-4D c815 R*8 VAR COMMON 66 56 5-2D 5-4D caz R*8 (8) VAR COMMON 105 784 2-2D 2-4D caz2 R*8 (8) VAR COMMON 105 912 2-2D 2-4D cnvrt R*8 VAR COMMON 66 8 5-2D 5-4D 3243 code R*8 VAR COMMON 87 16 7-3D cofx R*8 (4,487) VAR AUTO 483 39184 3057D 3215A 3216A 3221A 3223A cons R*8 VAR COMMON 66 32 5-2D 5-4D 3242 cos_sin_theta R*8 VAR AUTO 483 47120 3240= cos_theta R*8 VAR AUTO 483 47112 3239= 3240 cos_view R*8 VAR AUTO 483 1248784 3258= delp R*8 VAR COMMON 70 40 23-3D 23-4D delx R*8 (10) VAR COMMON 126 0 10-2D 10-4D dtsp R*8 (202) VAR COMMON 83 5656 6-2D 6-3D dtts R*8 (202) VAR COMMON 83 7272 6-2D 6-3D e0za R*8 (9,15) VAR COMMON 128 0 16-2D 16-3D 3262 e1za R*8 (9,15,8) VAR COMMON 128 1080 16-2D 16-3D e2za R*8 (9,15,8) VAR COMMON 128 9720 16-2D 16-3D eiaz1 R*8 (15,8) VAR COMMON 117 360 12-2D 12-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 12-2D 12-3D eitl R*8 (15,8) VAR COMMON 188 0 17-2D 17-3D 3262 eitotz R*8 (15,8,11) VAR COMMON 444 21120 18-2D 18-3D eitr R*8 (15,8) VAR COMMON 188 960 17-2D 17-3D 3262 eittl R*8 (15,8,11) VAR COMMON 444 0 18-2D 18-3D eittr R*8 (15,8,11) VAR COMMON 444 10560 18-2D 18-3D eitu R*8 (15,8) VAR COMMON 188 1920 17-2D 17-3D 3262 eizero R*8 (15) VAR COMMON 117 240 12-2D 12-3D 3256 ematx R*8 (3,15) VAR COMMON 105 0 2-2D 2-4D emu R*8 (15) VAR COMMON 105 976 2-2D 2-4D 3227(2) emuz R*8 (10) VAR COMMON 105 1096 2-2D 2-4D end_wave R*8 VAR COMMON 493 536 8-6D 8-7D 3173 3194A 3280A f1 R*8 VAR AUTO 483 48752 3248A f2 R*8 VAR AUTO 483 48760 3248A file_name CH*200 VAR AUTO 483 216 3061D 3113= 3115A 3117 3120= 3122A 3124 3126= 3128A 3130 3135A 3136 3294= 3296A 3299 fracin R*8 VAR AUTO 483 47000 3221A 3246A fs R*8 VAR COMMON 117 2288 12-2D 12-3D 3248A 3261 3262 gama R*8 VAR COMMON 70 8 23-3D 23-4D gg R*8 VAR COMMON 117 2280 12-2D 12-3D 3261 3262 ggz R*8 (9) VAR COMMON 128 18360 16-2D 16-3D 3262 h R*8 (487) VAR AUTO 483 43096 3057D 3221A 3223A 3246A hhold R*8 (101) VAR COMMON 85 1904 11-3D 11-5D 3213A 3221A i I*4 VAR AUTO 483 4868848 3302(2) 3303(3)= 3305(3)= 3307(3)= 3309(3)= i0_out R*8 (6,10,2500) VAR AUTO 483 1248768 3046D 3256= 3262 3303 iaz I*4 VAR AUTO 483 4848836 3262(9)= iazmth I*4 VAR COMMON 85 12 11-2D 11-5D 3171 3182(2) 3211A 3262(4) ijk I*4 VAR AUTO 483 47016 3234= 3236 3237 3238 3239 3240 3242 3250A 3256 3259 3260 3261 3262(5) 3278= imu I*4 VAR COMMON 85 4 11-2D 11-5D 3142 3144 3211A 3223A 3225 3229A 3254 imuz I*4 VAR COMMON 85 8 11-2D 11-5D 3211A ipath I*4 VAR COMMON 126 192 10-3D 10-4D 3188= 3241 ipol I*4 VAR COMMON 70 64 23-2D 23-4D ipsudo I*4 VAR COMMON 126 188 10-3D 10-4D 3189= 3245 iter I*4 (12) VAR COMMON 493 280 8-3D 8-7D 3206 iter_lun I*4 VAR AUTO 483 304 3134A 3136 3262 3318 iter_num I*4 VAR AUTO 483 4848816 3262(8) iter_pos I*4 VAR AUTO 483 336 3191= 3202(2) 3204(2)= 3205(2) 3206 itmax I*4 VAR COMMON 126 184 10-3D 10-4D 3206= 3232A 3250A 3262(9) j I*4 VAR AUTO 483 324 3175(2) 3176(3)= 3179(3)= 3180(2) 3181(2) 3182(2) 3183(2) 3225= 3226 3227(3) 3228= 3254= 3256(2) 3257 3258 3259(2) 3260(2) 3261(3) 3262(12) 3276= 3303(3)= 3305(3)= 3307(3)= 3309(3)= 3311(2) jjprint I*4 VAR AUTO 483 12 3104= 3154= 3199 3208 jprint I*4 (10) VAR COMMON 124 0 14-2D 14-3D 3117 3130 3154(8) 3165 3175 3201 3236 3277 3298 js I*4 VAR AUTO 483 47012 3233= 3235(2)= 3237 jw I*4 VAR AUTO 483 332 3190= k I*4 VAR AUTO 483 4868852 3303(3)= 3305(3)= 3307(3)= 3309(3)= kskip R*8 VAR COMMON 66 104 5-2D 5-4D lambda I*4 VAR COMMON 85 2800 11-2D 11-5D 3200= layer I*4 VAR COMMON 85 2804 11-2D 11-5D 3220= 3221A layr I*4 VAR 3041D Variable declared and not used len I*4 VAR AUTO 483 316 3156= lgcorrect L*4 VAR COMMON 92 0 20-2D 20-3D 3101I lmax I*4 VAR AUTO 483 39196 3219= 3221A 3223A 3246A lsphout L*4 VAR COMMON 303 0 19-2D 19-3D 3096I 3222 lwav L*4 (12) VAR COMMON 488 0 4-2D 4-3D 3185A nalb I*4 VAR COMMON 85 0 11-2D 11-5D 3172 3183(2) 3262 nc I*4 VAR AUTO 483 39188 3216A 3223A 3229A ncp1 I*4 VAR AUTO 483 39192 3216A 3223A 3229A 3232A 3246A 3248A 3250A nek R*8 (202,5,202) VAR COMMON 263 0 3-2D 3-3D 3232A nscan I*4 VAR COMMON 493 548 8-3 8-7D 3170 3181(2) 3301 3303 3305 3307 3309 nthet I*4 VAR COMMON 493 544 8-3 8-7D 3148 3150 3169 3234 3301 3303 3305 3307 3309 num I*4 VAR AUTO 483 340 3193= 3194 3197(2)= 3198 3199 3256 3259 3260 3261 3262(4) 3279 3280 3284 3292 num_arg I*4 VAR AUTO 483 16 3111= 3112 3119 3125 3132 3293 num_iter I*4 VAR COMMON 493 552 8-3 8-7D 3202 3205 numek R*8 VAR COMMON 66 96 5-2D 5-4D nwavl I*4 VAR AUTO 483 4868844 3041D 3292= 3301 3302(2) 3303 3305 3307 3309 3311(2) p R*8 (101) VAR AUTO 483 21984 3054D 3215A pi R*8 VAR COMMON 66 0 5-2D 5-4D 3262(4) pnot R*8 VAR COMMON 87 24 7-2D 7-3D 3187= 3213A polz R*8 (15,8,11) VAR COMMON 444 31680 18-2D 18-3D pres R*8 VAR COMMON 493 176 8-5D 8-7D 3168 3187 prfnam CH*8 VAR COMMON 11 0 9-2D 9-4D 3156A 3166 ps R*8 (487) VAR AUTO 483 46992 3057D 3221A 3223A 3246A pscaleforg R*8 VAR COMMON 66 88 5-2D 5-4D pshold R*8 (101) VAR COMMON 85 1096 11-3D 11-5D 3213A 3221A psza R*8 (10) VAR AUTO 483 47096 3060D 3237= q R*8 VAR COMMON 70 16 23-3D 23-4D q1 R*8 VAR COMMON 70 24 23-3D 23-4D q12s R*8 VAR COMMON 70 56 23-3D 23-4D q2 R*8 VAR COMMON 70 32 23-3D 23-4D qr R*8 (11) VAR COMMON 117 32 12-2D 12-3D r R*8 VAR COMMON 66 16 5-2D 5-4D refdir R*8 (15) VAR COMMON 311 0 21-2D 21-3D 3226= 3227= 3261 rhon R*8 VAR COMMON 70 0 23-3D 23-4D 3194A 3280A rinv R*8 VAR COMMON 66 24 5-2D 5-4D ristar R*8 (15,11) VAR COMMON 435 0 13-2D 13-3D saz R*8 (8) VAR COMMON 105 720 2-2D 2-4D saz2 R*8 (8) VAR COMMON 105 848 2-2D 2-4D sb R*8 (4) VAR COMMON 117 0 12-2D 12-3D 3262 3279 sb_out R*8 (2500) VAR AUTO 483 4868840 3050D 3279= 3311 sbt R*8 VAR 3055D Variable declared and not used sbz R*8 (9) VAR COMMON 166 0 15-2D 15-3D 3262 scan R*8 (15) VAR COMMON 493 408 8-5D 8-7D 3181 3257A 3258A 3262 sdp R*8 VAR COMMON 70 48 23-3D 23-4D sin_view R*8 VAR AUTO 483 1248776 3257= sq2 R*8 VAR COMMON 66 40 5-2D 5-4D start_wave R*8 VAR COMMON 493 528 8-6D 8-7D 3173 3194A 3280A t R*8 (101) VAR AUTO 483 22792 3054D 3215A t_out R*8 (6,10,2500) VAR AUTO 483 4848784 3049D 3261= 3262 3309 tautot R*8 VAR COMMON 87 32 7-2D 7-3D 3227 3262 tensig R*8 (11) VAR COMMON 435 1320 13-2D 13-3D tensit R*8 VAR 3058D Variable declared and not used thenot R*8 VAR AUTO 483 47104 3238= 3242= 3243(2)= 3246A 3248A 3277A theta R*8 (10) VAR COMMON 493 328 8-5D 8-7D 3180 3236 3237 3238 3239A 3240A 3242 3262 thnot R*8 (10) VAR COMMON 85 2712 11-3D 11-5D 3211A thta R*8 (15) VAR COMMON 85 16 11-3D 11-5D 3211A tl R*8 (101) VAR AUTO 483 23600 3054D 3215A tmp0 R*8 VAR COMMON 126 176 10-2D 10-4D 3186= 3215A tmp10 R*8 (10) VAR COMMON 126 88 10-2D 10-4D tmp101 R*8 (101) VAR AUTO 483 21168 3056D 3213A 3215A tmpcf R*8 (2) VAR AUTO 483 360 3056D 3194(2)A 3215A 3280(2)A tmpprf R*8 (11) VAR COMMON 493 88 8-5D 8-7D 3178(2) 3213(2)A tmptop R*8 VAR COMMON 126 168 10-2D 10-4D tnstr R*8 (15) VAR COMMON 117 120 12-2D 12-3D 3261 tnstrl R*8 (15) VAR COMMON 166 1152 15-2D 15-3D tnstrr R*8 (15) VAR COMMON 166 1272 15-2D 15-3D tnstrz R*8 (9,15) VAR COMMON 166 72 15-2D 15-3D 3262 total R*8 (15,8,11) VAR COMMON 435 1408 13-2D 13-3D totint R*8 (15,8) VAR COMMON 117 2296 12-2D 12-3D tr R*8 VAR 3058D Variable declared and not used tsl R*8 (101) VAR COMMON 83 0 6-2D 6-3D tt R*8 (202) VAR COMMON 83 808 6-2D 6-3D ttl R*8 (202) VAR COMMON 83 4040 6-2D 6-3D ttlp R*8 (15) VAR COMMON 188 2880 17-2D 17-3D 3262 ttrp R*8 (15) VAR COMMON 188 3000 17-2D 17-3D 3262 tts R*8 (202) VAR COMMON 83 2424 6-2D 6-3D ttz R*8 (9,15) VAR COMMON 444 42240 18-2D 18-3D vms_compatible I*4 (2) VAR AUTO 483 4868876 3362(3)= wave_iter R*8 (12) VAR COMMON 493 184 8-4D 8-7D 3202 3205 wavel R*8 (2500) VAR AUTO 483 20360 3045D 3198= 3199 3302 wavelen R*8 VAR COMMON 87 40 7-2D 7-3D 3194A 3198 3200 3201 3202 3205 3208 3262 3280A wavnum CH*27 VAR COMMON 11 8 9-3D 9-4D write_iter_file L*4 VAR COMMON 462 0 1-2D 1-3D 3132= 3133 3262 3318 x R*8 (101) VAR COMMON 85 288 11-3D 11-5D 3213A 3215A xdel R*8 VAR AUTO 483 8 3059D 3103= xpnot R*8 VAR AUTO 483 21176 3213A 3216A xprf R*8 (11) VAR COMMON 493 0 8-5D 8-7D 3177(2) 3213(2)A xsav R*8 (11) VAR 3059D Variable declared and not used xtop R*8 VAR COMMON 126 80 10-2D 10-4D z R*8 (202) VAR AUTO 483 48744 3054D 3246A 3248A 3250A z1_out R*8 (6,10,2500) VAR AUTO 483 2448784 3047D 3259= 3262 3305 z1func R*8 (15) VAR COMMON 190 0 22-2D 22-3D 3259 z2_out R*8 (6,10,2500) VAR AUTO 483 3648784 3048D 3260= 3262 3307 z2func R*8 (15) VAR COMMON 190 120 22-2D 22-3D 3260 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 901 3317 6400 3325 6493 3330 6500 3336 6750 3341 7000 3346 7425 3351 7850 3354 2000 3278 6450 3326 6494 3331 6550 3337 6751 3342 7100 3347 7450 3352 7900 3358 2121 3209 6475 3327 6496 3332 6600 3338 6752 3343 7200 3348 7700 3353 7901 3359 6200 3323 6490 3328 6497 3333 6700 3339 6753 3344 7300 3349 7800 3355 7902 3361 6300 3324 6492 3329 6498 3335 6725 3340 6775 3345 7400 3350 7801 3356 0003363 function omerf (x, y, sq) 0003364 c ****************************************************************** 0003365 c 0003366 c this subroutine calculates chapman function as approximated by 0003367 c john a. fitzmaurice, appl. opt. 3,640(1964). 0003368 c 0003369 c method: 0003370 c omerf(h,mu)= sqrt(h*pi/2) exp(h*(mu**2)/2) 0003371 c 0003372 c where- h=layer height from the center of earth 0003373 c (in units of scale height of attenuating 0003374 c species) 0003375 c 0003376 c 0003377 c ****************************************************************** 0003378 implicit integer*4(i-n),real*8 (a-h,o-z) 0003379 real *8 a(5),dp,dy,dx,dt,dsum,dsq,domerf 0003380 data dp/0.3275911d+00/ 0003381 data a / 0003382 1 1.061405429d+00, -1.453152027d+00, 0003383 2 1.421413741d+00, -0.284496736d+00, 0003384 3 0.254829592d+00 / 0003385 dy = y 0003386 dx = x 0003387 dsq = sq 0003388 dt = 1.0d+00 / (1.0d+00 + dp * dx) 0003389 dsum = dt * a(1) 0003390 if (y .ge. 0.2) go to 20 0003391 do 10 i=2,5 0003392 10 dsum = dt * (a(i) + dsum) 0003393 domerf = dsum * dsq 0003394 omerf = domerf 0003395 return 0003396 c 0003397 c*****for all but large solar zenith angles use the series expansion 0003398 c***** of the chapman function 0003399 c 0003400 20 dt = 0.5d+00 / (dx**2) 0003401 domerf=(1.0d+00-dt*(1.d+00-3.d+00*dt*(1.d+00-5.d+00*dt)))/dy 0003402 omerf = domerf 0003403 return 0003404 end ENTRY POINTS Name Type BlockNo omerf R*8 314 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References omerf R*8 3363D 3394= 3402= VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (5) VAR DATA 645 0 3379D 3381I 3389 3392 domerf R*8 VAR AUTO 314 64 3379D 3393= 3394 3401= 3402 dp R*8 VAR DATA 644 0 3379D 3380I 3388 dsq R*8 VAR AUTO 314 32 3379D 3387= 3393 dsum R*8 VAR AUTO 314 48 3379D 3389= 3392(2)= 3393 dt R*8 VAR AUTO 314 40 3379D 3388= 3389 3392 3400= 3401(3) dx R*8 VAR AUTO 314 24 3379D 3386= 3388 3400 dy R*8 VAR AUTO 314 16 3379D 3385= 3401 i I*4 VAR AUTO 314 52 3391= 3392(2)= sq R*8 VAR ARG 3363D 3387 x R*8 VAR ARG 3363D 3386 y R*8 VAR ARG 3363D 3385 3390 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 3392 20 3400 0003405 subroutine opthik(x,p,t,tl,cofx,tmp0,tmpcof,tmp101) 0003406 c 0003407 c*********************************************************************** 0003408 cccc 0003409 c subroutine opthik 0003410 c 0003411 c purpose- 0003412 c divide the atmosphere into layers and calculate their 0003413 c absorption,scattering and total optical depths measured from 0003414 c top of the atmosphere. 0003415 c 0003416 c method- 0003417 c uses spline interpolation to calculate optical thickness values 0003418 c on finer grid points than those obtained from the input data 0003419 c 0003420 c calling sequence- call opthik(x,p,t,tl,cofx) 0003421 c 0003422 c variable type i/o description 0003423 c -------- ---- --- ----------- 0003424 c 0003425 c x(101) r*8 i cumulative ozone thicknesses 0003426 c 0003427 c p(101) r*8 o pressure at each layer (atmospheres) 0003428 c t(101) r*8 o total optical depth of each layer 0003429 c tl(101) r*8 o log(t) 0003430 c cofx(4,487) r*8 o spline interpolation coeff. 0003431 c 0003432 c this subroutine also returns(thru' the common 'thkns' ) 0003433 c 0003434 c tsl(101) r*8 o log(scattering optical depth) 0003435 c tts(202) r*8 o interpolated scattering opt. depth 0003436 c tt(202) r*8 o interpolated total opt. depth 0003437 c ttl(202) r*8 o log(tt) 0003438 c 0003439 c 0003440 c external references- 0003441 c splset 0003442 c last modified......11/4/94 zia ahmad 0003443 c purpose............to correct the raleigh optical thickness 0003444 c for 1/r**2 effect of gravity 0003445 c last modified......03/10/95 dave flittner 0003446 c purpose............to set radius of earth equal to value in consts 0003447 c 0003448 c last modified 03/14/95...dave flittner 0003449 c purpose: set pressure scale height used in gravity correction 0003450 c to rayleigh scattering od. Create new variable pscaleforg and 0003451 c to impliment the gravity correction to the rayleigh scattering 0003452 c optical depth. 0003453 c 0003454 cccc 0003455 c*********************************************************************** 0003456 c 0003457 implicit integer*4(i-n),real*8 (a-h,o-z) 0003458 real *8 p(101),t(101),tl(101),x(101),cofx(4,487),tmpcof(2), 0003459 & tmp0,tmp101(101) 0003460 c 0003461 include "prints.inc" 0003462 include "atmos.inc" 0003463 include "consts.inc" 0003464 include "thkns.inc" 0003465 include "cgcorrect.inc" 0003466 c 0003467 c*****divide the atmosphere into 101 layers by a linear interpolation 0003468 c*****of log(p) (pmax=1, pmin=1.0e-5) 0003469 c*****store p and calculate log(ts),t and log(t) 0003470 c 0003471 elg = dlog(10.d+00) 0003472 dum2a = 0.05*elg 0003473 betal = dlog(beta) 0003474 do 10 i = 1, 101 0003475 plog = dum2a*float(i-101) 0003476 p(i) = dexp(plog) 0003477 c 0003478 c determine the height above the ground(p=1.0) using a constant 0003479 c scale height of H=6.95 and the g(h). Assume the radius of earth 0003480 c as: r0=r (in commmon block consts) and then compute the ratio: g0/g(h) 0003481 c the value of H is set in iniclz and is divided by the radius of !def 0003482 c the earth. !def 0003483 if(lgcorrect)then !def 0003484 gr=(1.0d0-pscaleforg*dlog(p(i)))**2 !def 0003485 grl=dlog(gr) 0003486 else !def 0003487 gr=1.0d0 !def 0003488 grl=0.0d0 !def 0003489 endif !def 0003490 c 0003491 deltmp=tmp101(i) - tmp0 0003492 alpha=alpha0+tmpcof(1)*deltmp+tmpcof(2)*deltmp**2 0003493 ta = alpha*x(i) 0003494 C ts = beta*p(i) 0003495 ts = beta*p(i)*gr 0003496 t(i) = ta + ts 0003497 tl(i) = dlog(t(i)) 0003498 C tsl(i) = betal + plog 0003499 tsl(i) = betal + plog + grl 0003500 if (jprint(5) .eq. 1) 0003501 1 write(33,101) i,x(i),p(i),t(i),tsl(i),tl(i),tmp101(i) 0003502 10 continue 0003503 c 0003504 c*****fit a spline between log(ts) and log(t) 0003505 c 0003506 call splset (tsl,tl,cofx,101) 0003507 c 0003508 c 0003509 c*****increase the no. of layers to 202 by preferentially adding 0003510 c*****layers at the atmosphere bottom using a quadratic function. 0003511 c 0003512 cnsta = -3.4219e-3 0003513 cnstb = 6.7056e-2 0003514 tt(1) = 0. 0003515 tts(1) = 0. 0003516 jb = 2 0003517 do 20 i = 2, 202 0003518 adum = float(202-i) 0003519 ttsl = betal + cnsta*adum*(1. + cnstb*adum) 0003520 tts(i) = dexp(ttsl) 0003521 c 0003522 c*****search for two layers in the old atmos. stradlling a given 0003523 c*****layer in the new atmos. and find tt by spline interpolation 0003524 c 0003525 do 15 j = jb, 101 0003526 if (ttsl .gt. tsl(j)) go to 15 0003527 dum1 = tsl(j) - ttsl 0003528 kb = j - 1 0003529 dum2 = ttsl - tsl(kb) 0003530 dum3 = dum1*(cofx(1,kb)*dum1**2 + cofx(3,kb)) + dum2*(cofx(2,kb)* 0003531 1dum2**2 + cofx(4,kb)) 0003532 ttl(i) = dum3 0003533 tt(i) = dexp(dum3) 0003534 go to 20 0003535 15 continue 0003536 20 continue 0003537 return 0003538 101 format(i4,6d15.4) 0003539 end INCLUDE FILES FileNo File name 1 prints.inc 2 atmos.inc 3 consts.inc 4 thkns.inc 5 cgcorrect.inc ENTRY POINTS Name Type BlockNo opthik SUBR 591 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dexp INTRINSIC 3476 3520 3533 dlog INTRINSIC 3473 3484 3485 3497 float INTRINSIC 3475 3518 opthik SUBR 3405D splset SUBR EXTERNAL 3506 COMMON BLOCKS Name Size BlockNo atmos_ 48 87 cgcorrect_ 4 92 consts_ 112 66 prints_ 40 124 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References adum R*8 VAR AUTO 591 136 3518= 3519(2) alpha R*8 VAR AUTO 591 88 3492= 3493 alpha0 R*8 VAR COMMON 87 0 2-2D 2-3D 3492 beta R*8 VAR COMMON 87 8 2-2D 2-3D 3473A 3495 betal R*8 VAR AUTO 591 24 3473= 3499 3519 c1415 R*8 VAR COMMON 66 72 3-2D 3-4D c215 R*8 VAR COMMON 66 48 3-2D 3-4D c2815 R*8 VAR COMMON 66 80 3-2D 3-4D c38sq2 R*8 VAR COMMON 66 64 3-2D 3-4D c815 R*8 VAR COMMON 66 56 3-2D 3-4D cnsta R*8 VAR AUTO 591 112 3512= 3519 cnstb R*8 VAR AUTO 591 120 3513= 3519 cnvrt R*8 VAR COMMON 66 8 3-2D 3-4D code R*8 VAR COMMON 87 16 2-3D cofx R*8 (4,487) VAR ARG 3405D 3458D 3506A 3530(4) cons R*8 VAR COMMON 66 32 3-2D 3-4D deltmp R*8 VAR AUTO 591 80 3491= 3492(2) dtsp R*8 (202) VAR COMMON 83 5656 4-2D 4-3D dtts R*8 (202) VAR COMMON 83 7272 4-2D 4-3D dum1 R*8 VAR AUTO 591 160 3527= 3530(2) dum2 R*8 VAR AUTO 591 176 3529= 3530(2) dum2a R*8 VAR AUTO 591 16 3472= 3475 dum3 R*8 VAR AUTO 591 184 3530= 3532 3533A elg R*8 VAR AUTO 591 8 3471= 3472 gr R*8 VAR AUTO 591 56 3484= 3485A 3487= 3495 grl R*8 VAR AUTO 591 72 3485= 3488= 3499 i I*4 VAR AUTO 591 28 3474= 3475 3476 3484 3491 3493 3495 3496 3497(2) 3499 3500(7) 3502= 3517= 3518 3520 3532 3533 3536= j I*4 VAR AUTO 591 148 3525= 3526 3527 3528 3535= jb I*4 VAR AUTO 591 124 3516= 3525 jprint I*4 (10) VAR COMMON 124 0 1-2D 1-3D 3500 kb I*4 VAR AUTO 591 164 3528= 3529 3530(4) kskip R*8 VAR COMMON 66 104 3-2D 3-4D lgcorrect L*4 VAR COMMON 92 0 5-2D 5-3D 3483 numek R*8 VAR COMMON 66 96 3-2D 3-4D p R*8 (101) VAR ARG 3405D 3458D 3476= 3484A 3495 3500 pi R*8 VAR COMMON 66 0 3-2D 3-4D plog R*8 VAR AUTO 591 40 3475= 3476A 3499 pnot R*8 VAR COMMON 87 24 2-2D 2-3D pscaleforg R*8 VAR COMMON 66 88 3-2D 3-4D 3484 r R*8 VAR COMMON 66 16 3-2D 3-4D rinv R*8 VAR COMMON 66 24 3-2D 3-4D sq2 R*8 VAR COMMON 66 40 3-2D 3-4D t R*8 (101) VAR ARG 3405D 3458D 3496= 3497A 3500 ta R*8 VAR AUTO 591 96 3493= 3496 tautot R*8 VAR COMMON 87 32 2-2D 2-3D tl R*8 (101) VAR ARG 3405D 3458D 3497= 3500 3506A tmp0 R*8 VAR ARG 3405D 3458D 3491 tmp101 R*8 (101) VAR ARG 3405D 3458D 3491 3500 tmpcof R*8 (2) VAR ARG 3405D 3458D 3492(2) ts R*8 VAR AUTO 591 104 3495= 3496 tsl R*8 (101) VAR COMMON 83 0 4-2D 4-3D 3499= 3500 3506A 3526 3527 3529 tt R*8 (202) VAR COMMON 83 808 4-2D 4-3D 3514= 3533= ttl R*8 (202) VAR COMMON 83 4040 4-2D 4-3D 3532= tts R*8 (202) VAR COMMON 83 2424 4-2D 4-3D 3515= 3520= ttsl R*8 VAR AUTO 591 144 3519= 3520A 3526 3527 3529 wavelen R*8 VAR COMMON 87 40 2-2D 2-3D x R*8 (101) VAR ARG 3405D 3458D 3493 3500 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 3502 15 3535 20 3536 101 3538 0003540 subroutine prfmod(layer,xsav,xdel) 0003541 c author: c seftor 0003542 c date: 4-mar-91 0003543 c purpose: provide interface for profile modification studies 0003544 implicit integer*4(i-n), real*8(a-h,o-z) 0003545 real*8 xsav(11) 0003546 c 0003547 include "input.inc" 0003548 c 0003549 do 10 i = 1,11 0003550 xprf(i) = xsav(i) 0003551 10 continue 0003552 xchng = 0.1 * xprf(layer) 0003553 xprf(layer) = xprf(layer) - xchng 0003554 xdel = -xchng 0003555 return 0003556 end INCLUDE FILES FileNo File name 1 input.inc ENTRY POINTS Name Type BlockNo prfmod SUBR 662 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References prfmod SUBR 3540D COMMON BLOCKS Name Size BlockNo input_ 556 493 PARAMETERS Name Type References max_num_iter I*4 1-2D 1-3 1-4 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References end_wave R*8 VAR COMMON 493 536 1-6D 1-7D i I*4 VAR AUTO 662 4 3549= 3550(2) 3551= iter I*4 (12) VAR COMMON 493 280 1-3D 1-7D layer I*4 VAR ARG 3540D 3552 3553(2) nscan I*4 VAR COMMON 493 548 1-3 1-7D nthet I*4 VAR COMMON 493 544 1-3 1-7D num_iter I*4 VAR COMMON 493 552 1-3 1-7D pres R*8 VAR COMMON 493 176 1-5D 1-7D scan R*8 (15) VAR COMMON 493 408 1-5D 1-7D start_wave R*8 VAR COMMON 493 528 1-6D 1-7D theta R*8 (10) VAR COMMON 493 328 1-5D 1-7D tmpprf R*8 (11) VAR COMMON 493 88 1-5D 1-7D wave_iter R*8 (12) VAR COMMON 493 184 1-4D 1-7D xchng R*8 VAR AUTO 662 16 3552= 3553 3554 xdel R*8 VAR ARG 3540D 3554= xprf R*8 (11) VAR COMMON 493 0 1-5D 1-7D 3550= 3552 3553(2)= xsav R*8 (11) VAR ARG 3540D 3545D 3550 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 3551 0003557 subroutine readin 0003558 c 0003559 c author: c. seftor 0003560 c date: 28-jan-1991 0003561 c purpose: reads in all necessary input for the mateer code 0003562 c 0003563 implicit integer*4(i-n), real*8(a-h,o-z) 0003564 character file_name*200 0003565 c 0003566 include "input.inc" 0003567 include "inchr.inc" 0003568 include "log.inc" 0003569 include "contrl.inc" 0003570 include "in.inc" 0003571 include "prints.inc" 0003572 c 0003573 c new statement 0003574 include "depolt.inc" 0003575 c end of statement 0003576 c 0003577 if (iargc() .eq. 0) then 0003578 file_name = 'PROF' 0003579 else 0003580 call getarg(1, file_name) 0003581 end if 0003582 open (unit=22, file=file_name, status='old') 0003583 read (22,'(a)') prfnam 0003584 read (22,*) pres 0003585 read (22,*) nthet 0003586 read (22,*) (theta(num),num=1,nthet) 0003587 read (22,*) nscan 0003588 read (22,*) (scan(num), num=1, nscan) 0003589 read (22,*) naz 0003590 read (22,*) (azmth(num), num=1, naz) 0003591 read (22,*) nalb 0003592 read (22,*) (alb(num), num=1, nalb) 0003593 0003594 read (22, *) wavel_start, wavel_stop 0003595 read (22,*) (xprf(num),num=11,1,-1) 0003596 read (22,*) (tmpprf(num),num=11,1,-1) 0003597 read (22,*) (jprint(i),i=1,10) 0003598 read (22,*) num_iter 0003599 if (num_iter .gt. max_num_iter) then 0003600 print*,'Number of iteration ranges requested was ', num_iter 0003601 print*,'Maximum allowed is ', max_num_iter,' Program stopped.' 0003602 stop 'Too many iteration ranges requested.' 0003603 end if 0003604 read (22,*) (wave_iter(i),i=1,num_iter) 0003605 read (22,*) (iter(i),i=1,num_iter) 0003606 read (22,*) ipol 0003607 close (22) 0003608 imuz = nthet 0003609 imu = nscan 0003610 iazmth =naz 0003611 do i=1, nthet 0003612 thnot(i) = theta(i) 0003613 end do 0003614 0003615 do i = 1, nscan 0003616 thta(i) = scan(i) 0003617 end do 0003618 if (jprint(9).eq.1) then 0003619 write (*, '(''PRFNAM = '',a)') prfnam 0003620 write (*, *) 'PRES = ', pres 0003621 write (*,*) 'NTHET = ', nthet 0003622 write (*,*) 'THETA = ', (theta(num),num=1,nthet) 0003623 write (*,*) 'NSCAN = ',nscan 0003624 write (*,*) 'SCAN = ', (scan(num),num=1,nscan) 0003625 write (*,*) 'NAZ = ',naz 0003626 write (*,*) 'azmth = ', (azmth(num),num=1, naz) 0003627 write (*,*) 'NALB = ',nalb 0003628 write (*,*) 'ALB = ', (alb(num),num=1,nalb) 0003629 write (*, *) 'START, stop = ', wavel_start, wavel_stop 0003630 write (*,*) 'Ozone profile =',xprf 0003631 write (*,*) 'Temp profile =',tmpprf 0003632 write (*,*) 'jprint =', (jprint(i),i=1,8) 0003633 write (*,*) 'NUM_ITER = ', num_iter 0003634 write (*,*) (wave_iter(i), i=1,num_iter) 0003635 write (*,*) (iter(i),i=1,num_iter) 0003636 write (*,*) 'IPOL = ', ipol 0003637 endif 0003638 return 0003639 end INCLUDE FILES FileNo File name 1 input.inc 2 inchr.inc 3 log.inc 4 contrl.inc 5 in.inc 6 prints.inc 7 depolt.inc ENTRY POINTS Name Type BlockNo readin SUBR 509 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References getarg SUBR EXTERNAL 3580 iargc I*4 EXTERNAL 3577 readin SUBR 3557D COMMON BLOCKS Name Size BlockNo contrl_ 2808 85 depolt_ 68 70 in_ 196 126 inchr_ 35 11 input_ 556 493 log_ 48 488 prints_ 40 124 PARAMETERS Name Type References max_num_iter I*4 1-2D 1-3 1-4 3599 3601 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References alb R*8 (11) VAR COMMON 85 200 4-3D 4-5D 3592= 3628 alfaef R*8 VAR COMMON 85 2792 4-5D azmth R*8 (8) VAR COMMON 85 136 4-3D 4-5D 3590= 3626 delp R*8 VAR COMMON 70 40 7-3D 7-4D delx R*8 (10) VAR COMMON 126 0 5-2D 5-4D end_wave R*8 VAR COMMON 493 536 1-6D 1-7D file_name CH*200 VAR AUTO 509 208 3564D 3578= 3580A 3582 gama R*8 VAR COMMON 70 8 7-3D 7-4D hhold R*8 (101) VAR COMMON 85 1904 4-3D 4-5D i I*4 VAR AUTO 509 324 3597(2)= 3604(2)= 3605(2)= 3611= 3612(2) 3613= 3615= 3616(2) 3617= 3632(2) 3634(2) 3635(2) iazmth I*4 VAR COMMON 85 12 4-2D 4-5D 3610= imu I*4 VAR COMMON 85 4 4-2D 4-5D 3609= imuz I*4 VAR COMMON 85 8 4-2D 4-5D 3608= ipath I*4 VAR COMMON 126 192 5-3D 5-4D ipol I*4 VAR COMMON 70 64 7-2D 7-4D 3606= 3636 ipsudo I*4 VAR COMMON 126 188 5-3D 5-4D iter I*4 (12) VAR COMMON 493 280 1-3D 1-7D 3605= 3635 itmax I*4 VAR COMMON 126 184 5-3D 5-4D jprint I*4 (10) VAR COMMON 124 0 6-2D 6-3D 3597= 3618 3632 lambda I*4 VAR COMMON 85 2800 4-2D 4-5D layer I*4 VAR COMMON 85 2804 4-2D 4-5D lwav L*4 (12) VAR COMMON 488 0 3-2D 3-3D nalb I*4 VAR COMMON 85 0 4-2D 4-5D 3591= 3592(2) 3627 3628(2) naz I*4 VAR AUTO 509 304 3589= 3590(2) 3610 3625 3626(2) nscan I*4 VAR COMMON 493 548 1-3 1-7D 3587= 3588(2) 3609 3615 3623 3624(2) nthet I*4 VAR COMMON 493 544 1-3 1-7D 3585= 3586(2) 3608 3611 3621 3622(2) num I*4 VAR AUTO 509 296 3586(2)= 3588(2)= 3590(2)= 3592(2)= 3595(3)= 3596(3)= 3622(2) 3624(2) 3626(2) 3628(2) num_iter I*4 VAR COMMON 493 552 1-3 1-7D 3598= 3599 3600 3604(2) 3605(2) 3633 3634(2) 3635(2) pres R*8 VAR COMMON 493 176 1-5D 1-7D 3584= 3620 prfnam CH*8 VAR COMMON 11 0 2-2D 2-4D 3583= 3619 pshold R*8 (101) VAR COMMON 85 1096 4-3D 4-5D q R*8 VAR COMMON 70 16 7-3D 7-4D q1 R*8 VAR COMMON 70 24 7-3D 7-4D q12s R*8 VAR COMMON 70 56 7-3D 7-4D q2 R*8 VAR COMMON 70 32 7-3D 7-4D rhon R*8 VAR COMMON 70 0 7-3D 7-4D scan R*8 (15) VAR COMMON 493 408 1-5D 1-7D 3588= 3616 3624 sdp R*8 VAR COMMON 70 48 7-3D 7-4D start_wave R*8 VAR COMMON 493 528 1-6D 1-7D theta R*8 (10) VAR COMMON 493 328 1-5D 1-7D 3586= 3612 3622 thnot R*8 (10) VAR COMMON 85 2712 4-3D 4-5D 3612= thta R*8 (15) VAR COMMON 85 16 4-3D 4-5D 3616= tmp0 R*8 VAR COMMON 126 176 5-2D 5-4D tmp10 R*8 (10) VAR COMMON 126 88 5-2D 5-4D tmpprf R*8 (11) VAR COMMON 493 88 1-5D 1-7D 3596= 3631(2) tmptop R*8 VAR COMMON 126 168 5-2D 5-4D wave_iter R*8 (12) VAR COMMON 493 184 1-4D 1-7D 3604= 3634 wavel_start R*8 VAR AUTO 509 312 3594= 3629 wavel_stop R*8 VAR AUTO 509 320 3594= 3629 wavnum CH*27 VAR COMMON 11 8 2-3D 2-4D x R*8 (101) VAR COMMON 85 288 4-3D 4-5D xprf R*8 (11) VAR COMMON 493 0 1-5D 1-7D 3595= 3630(2) xtop R*8 VAR COMMON 126 80 5-2D 5-4D 0003640 0003641 subroutine reflex(itmax,nek,ncp1) 0003642 c 0003643 c*********************************************************************** 0003644 cccc 0003645 c subroutine reflex 0003646 c 0003647 c version aug 22,1977 0003648 c 0003649 c purpose 0003650 c 0003651 c reflex is a fortran iv routine to calculate the fract. of surf. 0003652 c reflected radiation which is back scattered by the atmosphere. 0003653 c it also computes the ratio of the intensity of light emerging 0003654 c from the top of the atmosphere (which was surface reflected ) 0003655 c to the intensity of light reflected by the lambertian surface. 0003656 c this quantity is tenstr=i-star /i-g,see eq 6.7 0003657 c 0003658 c method 0003659 c 0003660 c the scattering of radiations scattered by the ground is 0003661 c computed.the z-star matrix elements are calculated. 0003662 c by iteration. 0003663 c 0003664 c calling sequence 0003665 c 0003666 c call reflex (nek,itmax,ncp1,tnstr,qr) 0003667 c 0003668 c variable type i/o description 0003669 c -------- ---- --- ----------- 0003670 c 0003671 c nek i*4 i fortran data set unit # for 0003672 c file containing exponential integrals 0003673 c created by expone 0003674 c itmax i*4 i number of iteration steps to be used 0003675 c ncp1 i*4 i # layers 0003676 c tnstr(15) r*8 o intensity ratio described above for 0003677 c each polar back scatter angle. 0003678 c qr(10) r*8 o factor to be used in computing i-sb-g 0003679 c see eqn 6.7 0003680 c 0003681 c external references 0003682 c evalrf 0003683 c 0003684 c common areas referenced 0003685 c 0003686 c eks 0003687 c thkns 0003688 c analysis and programming 0003689 c k.f. klenk, p.m. smith sasc,aug 21 1977 0003690 c 0003691 c modifications (date name purpose) 0003692 c 0003693 c last modified 11/19/92....zia ahmad 0003694 c modified for single iteration 0003695 c last modified 10/19/94....zia ahmad 0003696 c modified to print results after each itration 0003697 c last modified 03/07/95....dave flittner 0003698 c modified to initialize itp to zero, so that one iteration 0003699 c may be done. 0003700 c last modified 03/08/95 by dave flittner 0003701 c modified to call eva1pol after each iteration if switch 0003702 c write_iter_file is TRUE 0003703 c last modified 03/14/95...dave flittner 0003704 c purpose: set pressure scale height used in gravity correction 0003705 c to rayleigh scattering od. Create new variable pscaleforg and 0003706 c pass in common block consts. 0003707 ccc 0003708 c********************************************************************** 0003709 c 0003710 implicit integer*4(i-n),real*8(a-h,o-z) 0003711 c 0003712 include "eks.inc" 0003713 include "consts.inc" 0003714 include "thkns.inc" 0003715 include "cwrite_iter.inc" 0003716 c 0003717 real*8 ekary(202,5),b1(202),b2(202),z1(202),z2(202), 0003718 1 zst1(4,202),zst2(4,202),tnstr(15) 0003719 real*8 nek(202,5,202) 0003720 real*8 temp1(4,202),temp2(4,202) 0003721 c 0003722 c construct zeroth z-star vector 0003723 c 0003724 itp=0 !def 0003725 itmm2=itmax-2 0003726 index=1 0003727 itmaxp=itmax+1 0003728 c 0003729 do 100 i=1,ncp1 0003730 z1(i)=ek4(i)/dtsp(i) 0003731 z2(i)=ek5(i)/dtsp(i) 0003732 c if (itmax.eq.1) then 0003733 zst1(1,i) = z1(i) 0003734 zst2(1,i) = z2(i) 0003735 temp1(1,i)=z1(i) 0003736 temp2(1,i)=z2(i) 0003737 c endif 0003738 100 continue 0003739 if(write_iter_file) call eva2pol(temp1,temp2,ncp1,1) !def 0003740 if (itmax.eq.1) goto 101 0003741 c 0003742 c do first and higher order iterations 0003743 c 0003744 do 140 it=1,itmax 0003745 c 0003746 c set b1,b2 equal to new z1,z2 0003747 c 0003748 do 150 k=1,ncp1 0003749 b1(k)=z1(k) 0003750 b2(k)=z2(k) 0003751 150 continue 0003752 c 0003753 c 0003754 do 280 i=1,ncp1 0003755 sum1=ek4(i)/dtsp(i) 0003756 sum2=ek5(i)/dtsp(i) 0003757 c 0003758 do 5100 ii = 1,202 0003759 do 5101 iii = 1,5 0003760 ekary(ii,iii) = nek(ii,iii,i) 0003761 5101 continue 0003762 5100 continue 0003763 c 0003764 do 190 j=1,ncp1 0003765 sum1=sum1+ekary(j,1)*b1(j)+ekary(j,2)*b2(j) 0003766 sum2=sum2+ekary(j,2)*b1(j)+ekary(j,3)*b2(j) 0003767 190 continue 0003768 c 0003769 c 0003770 z1(i)=sum1 0003771 z2(i)=sum2 0003772 c 0003773 temp1(1,i)=z1(i) 0003774 temp2(1,i)=z2(i) 0003775 0003776 c save zstar matrix of last three iterations 0003777 c 0003778 if(it.lt.itmm2) go to 280 0003779 c 0003780 zst1(index,i)=z1(i) 0003781 zst2(index,i)=z2(i) 0003782 280 continue 0003783 c 0003784 itp=it+1 0003785 if((itp .le. itmaxp).or.write_iter_file)then !def 0003786 call eva2pol(temp1,temp2,ncp1,itp) 0003787 endif 0003788 c 0003789 if(it.ge.itmm2) index=index+1 0003790 140 continue 0003791 101 continue 0003792 c 0003793 c call evalrf to calculate istar/ig of eq (6.7) 0003794 c for all polar look angles 0003795 c 0003796 itpp=itp+1 0003797 if(write_iter_file) call eva2pol(zst1,zst2,ncp1,itpp) !def 0003798 call evalrf(zst1,zst2,ncp1) 0003799 c 0003800 return 0003801 end INCLUDE FILES FileNo File name 1 eks.inc 2 consts.inc 3 thkns.inc 4 cwrite_iter.inc ENTRY POINTS Name Type BlockNo reflex SUBR 593 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References eva2pol SUBR EXTERNAL 3739 3786 3797 evalrf SUBR EXTERNAL 3798 reflex SUBR 3641D COMMON BLOCKS Name Size BlockNo consts_ 112 66 cwrite_iter_ 4 462 eks_ 27472 120 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References b1 R*8 (202) VAR AUTO 593 30744 3717D 3749= 3765 3766 b2 R*8 (202) VAR AUTO 593 32360 3717D 3750= 3765 3766 c1415 R*8 VAR COMMON 66 72 2-2D 2-4D c215 R*8 VAR COMMON 66 48 2-2D 2-4D c2815 R*8 VAR COMMON 66 80 2-2D 2-4D c38sq2 R*8 VAR COMMON 66 64 2-2D 2-4D c815 R*8 VAR COMMON 66 56 2-2D 2-4D cnvrt R*8 VAR COMMON 66 8 2-2D 2-4D cons R*8 VAR COMMON 66 32 2-2D 2-4D dtsp R*8 (202) VAR COMMON 83 5656 3-2D 3-3D 3730 3731 3755 3756 dtts R*8 (202) VAR COMMON 83 7272 3-2D 3-3D ek4 R*8 (202) VAR COMMON 120 24240 1-2D 1-3D 3730 3755 ek5 R*8 (202) VAR COMMON 120 25856 1-2D 1-3D 3731 3756 ekary R*8 (202,5) VAR AUTO 593 40464 3717D 3760= 3765(2) 3766(2) extmu R*8 (202,15) VAR COMMON 120 0 1-2D 1-3D i I*4 VAR AUTO 593 20 3729= 3730(3) 3731(3) 3733(2) 3734(2) 3735(2) 3736(2) 3738= 3754= 3755(2) 3756(2) 3760 3770 3771 3773(2) 3774(2) 3780(2) 3781(2) 3782= ii I*4 VAR AUTO 593 32380 3758= 3760(2) 3762= iii I*4 VAR AUTO 593 32384 3759= 3760(2) 3761= index I*4 VAR AUTO 593 12 3726= 3780 3781 3789(2)= it I*4 VAR AUTO 593 29116 3744= 3778 3784 3789 3790= itmax I*4 VAR ARG 3641D 3725 3727 3740 3744 itmaxp I*4 VAR AUTO 593 16 3727= 3785 itmm2 I*4 VAR AUTO 593 8 3725= 3778 3789 itp I*4 VAR AUTO 593 4 3724= 3784= 3785 3786A 3796 itpp I*4 VAR AUTO 593 40476 3796= 3797A j I*4 VAR AUTO 593 40468 3764= 3765(4) 3766(4) 3767= k I*4 VAR AUTO 593 29120 3748= 3749(2) 3750(2) 3751= kskip R*8 VAR COMMON 66 104 2-2D 2-4D ncp1 I*4 VAR ARG 3641D 3729 3739A 3748 3754 3764 3786A 3797A 3798A nek R*8 (202,5,202) VAR ARG 3641D 3719D 3760 numek R*8 VAR COMMON 66 96 2-2D 2-4D pi R*8 VAR COMMON 66 0 2-2D 2-4D pscaleforg R*8 VAR COMMON 66 88 2-2D 2-4D r R*8 VAR COMMON 66 16 2-2D 2-4D rinv R*8 VAR COMMON 66 24 2-2D 2-4D sq2 R*8 VAR COMMON 66 40 2-2D 2-4D sum1 R*8 VAR AUTO 593 32368 3755= 3765(2)= 3770 sum2 R*8 VAR AUTO 593 32376 3756= 3766(2)= 3771 temp1 R*8 (4,202) VAR AUTO 593 22648 3720D 3735= 3739A 3773= 3786A temp2 R*8 (4,202) VAR AUTO 593 29112 3720D 3736= 3739A 3774= 3786A tnstr R*8 (15) VAR 3717D Variable declared and not used tsl R*8 (101) VAR COMMON 83 0 3-2D 3-3D tt R*8 (202) VAR COMMON 83 808 3-2D 3-3D ttl R*8 (202) VAR COMMON 83 4040 3-2D 3-3D tts R*8 (202) VAR COMMON 83 2424 3-2D 3-3D write_iter_file L*4 VAR COMMON 462 0 4-2D 4-3D 3739 3785 3797 z1 R*8 (202) VAR AUTO 593 1640 3717D 3730= 3733 3735 3749 3770= 3773 3780 z2 R*8 (202) VAR AUTO 593 3256 3717D 3731= 3734 3736 3750 3771= 3774 3781 zst1 R*8 (4,202) VAR AUTO 593 9720 3717D 3733= 3780= 3797A 3798A zst2 R*8 (4,202) VAR AUTO 593 16184 3717D 3734= 3781= 3797A 3798A LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 3738 101 3791 140 3790 150 3751 190 3767 280 3782 5100 3762 5101 3761 0003802 subroutine relayr(delx,xtop,tmp10,tmptop,x101,tmp101, 0003803 1 pnot,xpnot,h,ps) 0003804 c ---------------------------------------------------------------- 0003805 c subroutine relayr 0003806 c 0003807 c 0003808 c version 2.0 june 1984 0003809 c algorithm designed by dr. p.k. bhartia ; coded by david lee ,sasc 0003810 c 0003811 c purpose - 0003812 c 0003813 c find the cumulative ozone amount and ozone-weighted average 0003814 c temperatures at 101 levels from input values for 10 umkehr 0003815 c layers using a spline fit. 0003816 c 0003817 c 0003818 c method / procedures 0003819 c 0003820 c 1) define input and output pressure levels 0003821 c 2) compute accumulated ozone amounts at input levels 0003822 c 3) compute ozone weighted average temperatures above input 0003823 c pressure levels 0003824 c 4) perform a spline fit to temperatures and accumulated 0003825 c ozones at input levels 0003826 c 5) evaluate spline fit at the lowest 61 pressure levels 0003827 c 6) find slope for the accumulated ozone at the 41st. level 0003828 c 7) evaluaate accumulated ozone amounts for the top 40 levels 0003829 c from the slope computed from the 41st level 0003830 c 8) compute pressures for altitudes at 1 km intervals 0003831 c 0003832 c 0003833 c calling sequence - call relayr(delx,xtop,tmp10,tmptop,x101,tmp101, 0003834 c h,ps) 0003835 c 0003836 c 0003837 c variable type i/o description 0003838 c -------- ---- --- ----------- 0003839 c 0003840 c delx(10) r*8 i layer ozone amount (d.u) for 0003841 c 10 umkehr layers. (layers 0-9, layer 0003842 c 0 being the bottom half of the atmos- 0003843 c phere). indexing of the layers are 0003844 c described in the table below 0003845 c 0003846 c xtop r*8 i cumulative ozone amount(m-atm-cm) 0003847 c above umkehr layer 9 0003848 c 0003849 c tmp10(10) r*8 i average temperatures (degrees kelvin) 0003850 c for 10 umkehr layers 0003851 c 0003852 c tmptop r*8 i average temperature for the 0003853 c atmosphere above umkehr layer 9 0003854 c 0003855 c p11(11) r*8 pressure levels (atm.) defining the 10 0003856 c umkehr layers. indexing of the pressure 0003857 c levels are described in the table 0003858 c below 0003859 c 0003860 c x11(11) r*8 cumulative ozone amount (m-atm-cm) 0003861 c at pressure levels described above 0003862 c for p11 0003863 c 0003864 c pnot r*8 i pressure of reflecting surface 0003865 c 0003866 c xpnot r*8 o cumulative ozone at pnot 0003867 c 0003868 c p101(101) r*8 pressure (atm.) at 101 atmospheric 0003869 c levels that define the output layer 0003870 c ozone amounts and temperatures 0003871 c 0003872 c x101(101) r*8 o output cumulative ozone amounts 0003873 c (atm-cm) at levels corresponding 0003874 c to p101. 0003875 c 0003876 c 0003877 c tmp101(101) r*8 o output ozone weighted temperatures 0003878 c (deg-kelvin) for atmospheres above 0003879 c each of the 101 pressure levels. 0003880 c 0003881 c z11(11) r*8 altitude (km) corresponding to p11 0003882 c defining the umkehr layers 0003883 c 0003884 c h(82) r*8 o altitude array at 1 km interval from 0003885 c ground to 82 km 0003886 c 0003887 c ps(82) r*8 o pressures corresponding to the height 0003888 c at the h array 0003889 c 0003890 c 0003891 c----------------------------------------------------------------------- 0003892 c 0003893 c----------------------------------------------------------------------- 0003894 c 0003895 c the table below describes the order of indices for variables 0003896 c in this subroutine 0003897 c 0003898 c pressure umkehr indices indices index 0003899 c (atm.) layer # for p11,x11 for delx for 0003900 c & t11ave & tmp10 z11 0003901 c 0003902 c 1/1024 -------------------------1--------------------------11 0003903 c 9 1 0003904 c 1/512---------------------------2--------------------------10 0003905 c 8 2 0003906 c 1/256---------------------------3---------------------------9 0003907 c 7 3 0003908 c 1/128---------------------------4---------------------------8 0003909 c 6 4 0003910 c 1/64 ---------------------------5---------------------------7 0003911 c 5 5 0003912 c 1/32 ---------------------------6---------------------------6 0003913 c 4 6 0003914 c 1/16 ---------------------------7---------------------------5 0003915 c 3 7 0003916 c 1/8 ---------------------------8---------------------------4 0003917 c 2 8 0003918 c 1/4 ---------------------------9---------------------------3 0003919 c 1 9 0003920 c 1/2 --------------------------10---------------------------2 0003921 c 0 10 0003922 c 1 --------------------------11---------------------------1 0003923 c 0003924 c 0003925 c last modified 03/10/95...dave flittner 0003926 c purpose: set earth radius equal to value in common block consts 0003927 c 0003928 c last modified 03/14/95...dave flittner 0003929 c purpose: set pressure scale height used in gravity correction 0003930 c to rayleigh scattering od. Create new variable pscaleforg and 0003931 c pass in common block consts. 0003932 c-------------------------------------------------------------------- 0003933 implicit integer*4(i-n),real*8(a-h,o-z) 0003934 real*8 p11(11),p11log(11),p101(101),p101lg(101), 0003935 1 x11(11),x11log(11),x101(101),x101lg(101),delx(10), 0003936 2 tmp10(10),tmp101(101),t11ave(11) 0003937 dimension z11(11),plginv(11),ps(82),h(82) 0003938 dimension cx(11),bparx(4),ct(11),bpart(4),cz(11),bparz(4) 0003939 c 0003940 include "consts.inc" 0003941 include "prints.inc" 0003942 c 0003943 c*****define presures (atm.) for layer ozone amounts and temperatures. 0003944 c p11(11) is the at the bottom of the atmosphere 0003945 c 0003946 do 10 i=1,11 0003947 p11(i)=1.0*2.**(i-11.) 0003948 p11log(i)=dlog(p11(i)) 0003949 10 continue 0003950 c 0003951 c*****define pressures (atm.) at 101 levels for output ozone and 0003952 c temperatures p101(101) is at the bottom of the atmosphere 0003953 c 0003954 do 20 i=1,101 0003955 p101(i)=1.0*10.**((i-101.)/20.) 0003956 p101lg(i)=dlog(p101(i)) 0003957 20 continue 0003958 c 0003959 c*****compute cumulative ozone at 11 pressure levels & convert to atm-cm 0003960 c 0003961 x11(1)=xtop/1000. 0003962 x11log(1)=dlog(x11(1)) 0003963 do 110 i=2,11 0003964 x11(i)=x11(i-1)+delx(i-1)/1000. 0003965 x11log(i)=dlog(x11(i)) 0003966 110 continue 0003967 c 0003968 c*****compute ozone weighted average temperatures at 11 pressure level 0003969 c 0003970 tsum=tmptop*xtop/1000. 0003971 t11ave(1)=tmptop 0003972 do 150 i=2,11 0003973 tsum=tsum+tmp10(i-1)*delx(i-1)/1000. 0003974 t11ave(i)=tsum/x11(i) 0003975 150 continue 0003976 c 0003977 c*****set up boundary value parametes for cumulative ozone spline fit 0003978 c 0003979 bparx(1)=0. 0003980 bparx(2)=0. 0003981 bparx(3)=1. 0003982 c 0003983 c*****f'(nx)=1.707*layer 0 ozone / total ozone 0003984 c 0003985 deltax=x11log(11)-x11log(10) 0003986 deltap=p11log(11)-p11log(10) 0003987 fnx=1.707*delx(10)/1000./x11(11) 0003988 bparx(4)=6.0/deltap*(fnx-deltax/deltap) 0003989 c 0003990 c*****evaluate cumulative ozone at the lowest 61 output preure level 0003991 c using a spline fit to point at input pressure levels 0003992 c 0003993 nx=11 0003994 ic=10 0003995 l1=41 0003996 l2=101 0003997 m=l2-l1+1 0003998 call spline(p11log,x11log,nx,1.d30,fnx,cx) 0003999 do 175 i = l1,l2 0004000 call splint(p11log,x11log,cx,nx,p101lg(i),x101lg(i)) 0004001 175 continue 0004002 c 0004003 c***** evaluate cumulative ozone at pnot 0004004 c 0004005 xpnot=x11(11) 0004006 if (pnot.ge.p11(11)) go to 180 0004007 p0log=dlog(pnot) 0004008 call splint(p11log,x11log,cx,nx,p0log,xp0log) 0004009 c if(ier.ne.0) go to 900 0004010 xpnot=dexp(xp0log) 0004011 180 continue 0004012 if (jprint(6).eq.1) write(33,2000) xpnot 0004013 c 0004014 c*****evaluate cumultive ozone at uppermost 40 levels based on 0004015 c slope computed from the 41st and 42nd levels 0004016 c 0004017 slope=(x101lg(l1)-x101lg(l1+1))/(p101lg(l1)-p101lg(l1+1)) 0004018 c 0004019 l1m1=l1-1 0004020 do 200 l=1,l1m1 0004021 x101lg(l)=x101lg(l1)+slope*(p101lg(l)-p101lg(l1)) 0004022 200 continue 0004023 c 0004024 c***** convert log of cumulative ozone to cumulative ozone 0004025 c 0004026 do 250 l=1,101 0004027 x101(l)=dexp(x101lg(l)) 0004028 250 continue 0004029 c 0004030 c*****evaluate ozone-weighted average temperatures for atmospheres 0004031 c above lowest 61 output pressure levels using a spline fit to 0004032 c points at input pressure levels 0004033 c 0004034 bpart(1)=0. 0004035 bpart(2)=0. 0004036 bpart(3)=0. 0004037 bpart(4)=0. 0004038 call spline(p11log,t11ave,nx,1.d30,1.d30,ct) 0004039 do 275 i = l1,l2 0004040 call splint(p11log,t11ave,ct,nx,p101lg(i),tmp101(i)) 0004041 275 continue 0004042 c 0004043 c*****evaluate weighted temperatures in the upper most 40 layers 0004044 c based on constant lapse rate of -1.5 degrees per layer) 0004045 195 do 300 l=1,l1m1 0004046 tmp101(l)=tmp101(l1)-1.5*(l1-l) 0004047 300 continue 0004048 c 0004049 c*****compute heights z11 (km.) corresponding to the 11 input pressure 0004050 c levels p11 (in inverse order) using the equations : 0004051 c dz/dlogp=n*r*t/g 0004052 c g=g0*(r0/(r0+z))**2 0004053 c 0004054 c constant is g0/(n*r); z11(1) is at bottom of atmosphere 0004055 c 0004056 const=1.0/(-34.163) 0004057 r0=r 0004058 dzhalf=2.5 0004059 z11(1)=0. 0004060 plginv(1)=p11log(11) 0004061 do 400 i=2,11 0004062 j=12-i 0004063 plginv(i)=p11log(j) 0004064 dlogp=plginv(i)-plginv(i-1) 0004065 z=z11(i-1)+dzhalf 0004066 t=tmp10(j) 0004067 dz=const*((r0+z)/r0)**2*t*dlogp 0004068 z11(i)=z11(i-1)+dz 0004069 dzhalf=dz/2.0 0004070 400 continue 0004071 c 0004072 c*****perform a spline fit to log(p) and z 0004073 c 0004074 bparz(1)=0. 0004075 bparz(2)=0. 0004076 bparz(3)=0. 0004077 bparz(4)=0. 0004078 c if(ier.ne.0) go to 900 0004079 call spline(z11,plginv,nx,1.d30,1.d30,cz) 0004080 c 0004081 c*****set up altitude arrays at 1 km constant intervals 0004082 c 0004083 do 320 i=1,82 0004084 h(i)=float(i-1)*1.0 0004085 320 continue 0004086 c 0004087 c*****evaluate log of pressure at 1 km intervals from the ground to 0004088 c the top of umkehr layer 9 based on spline fit 0004089 c 0004090 m=z11(11)+1. 0004091 c if(ier.ne.0) go to 900 0004092 do 345 i = 1,m 0004093 call splint(z11,plginv,cz,nx,h(i),ps(i)) 0004094 345 continue 0004095 c 0004096 c*****evaluate log of pressues above umkehr layer 9 based on constant 0004097 c scale height 0004098 c 0004099 slope=(ps(m)-ps(m-1))/(h(m)-h(m-1)) 0004100 mp1=m+1 0004101 do 450 i=mp1,82 0004102 ps(i)=ps(m)+slope*(h(i)-h(m)) 0004103 450 continue 0004104 c 0004105 c***** convert log of pressure to pressure 0004106 c 0004107 do 460 i=1,82 0004108 ps(i)=dexp(ps(i)) 0004109 460 continue 0004110 c 0004111 c***** dump out variout input & ouput data 0004112 c 0004113 if (jprint(6).eq.1) 0004114 1 write(33,6200) tmptop,xtop,(i,p11(i),x11(i),t11ave(i),z11(12-i), 0004115 2 tmp10(i),delx(i),i=1,10),(i,p11(i),x11(i),t11ave(i),z11(12-i), 0004116 3 i=11,11) 0004117 if (jprint(6) .eq. 1) write(33,6210) (h(i),ps(i),i=1,82) 0004118 900 continue 0004119 return 0004120 2000 format(1x,'xpnot=',f10.5//) 0004121 6200 format(//' ozone,temperature & other variables in umkehr layers:'/ 0004122 1 /t28,'weighted',t51,'layer',t61,'layer'/1x,'index',t13,'p11',t23, 0004123 2 'x11',t32,'temp',t43,'z11',t52,'temp',t61,'ozone' 0004124 3 /t46,2f10.2/10(i3,2x,e10.4,f10.3,2f10.2/t46,2f10.2/), 0004125 4 i3,2x,e10.4,f10.3,2f10.2) 0004126 6210 format(/' pressures for first 82 km altitude :'/5(8x,'h',9x, 0004127 1 'ps',2x)/17(5(f10.1,e12.4)/)) 0004128 end INCLUDE FILES FileNo File name 1 consts.inc 2 prints.inc ENTRY POINTS Name Type BlockNo relayr SUBR 590 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dexp INTRINSIC 4010 4027 4108 dlog INTRINSIC 3948 3956 3962 3965 4007 float INTRINSIC 4084 relayr SUBR 3802D spline SUBR EXTERNAL 3998 4038 4079 splint SUBR EXTERNAL 4000 4008 4040 4093 COMMON BLOCKS Name Size BlockNo consts_ 112 66 prints_ 40 124 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References bpart R*8 (4) VAR AUTO 590 3128 3938D 4034= 4035= 4036= 4037= bparx R*8 (4) VAR AUTO 590 2112 3938D 3979= 3980= 3981= 3988= bparz R*8 (4) VAR AUTO 590 3496 3938D 4074= 4075= 4076= 4077= c1415 R*8 VAR COMMON 66 72 1-2D 1-4D c215 R*8 VAR COMMON 66 48 1-2D 1-4D c2815 R*8 VAR COMMON 66 80 1-2D 1-4D c38sq2 R*8 VAR COMMON 66 64 1-2D 1-4D c815 R*8 VAR COMMON 66 56 1-2D 1-4D cnvrt R*8 VAR COMMON 66 8 1-2D 1-4D cons R*8 VAR COMMON 66 32 1-2D 1-4D const R*8 VAR AUTO 590 3224 4056= 4067 ct R*8 (11) VAR AUTO 590 3216 3938D 4038A 4040A cx R*8 (11) VAR AUTO 590 2248 3938D 3998A 4000A 4008A cz R*8 (11) VAR AUTO 590 3584 3938D 4079A 4093A deltap R*8 VAR AUTO 590 2128 3986= 3988(2) deltax R*8 VAR AUTO 590 2120 3985= 3988 delx R*8 (10) VAR ARG 3802D 3934D 3964 3973 3987 4113 dlogp R*8 VAR AUTO 590 3432 4064= 4067 dz R*8 VAR AUTO 590 3456 4067= 4068 4069 dzhalf R*8 VAR AUTO 590 3240 4058= 4065 4069= fnx R*8 VAR AUTO 590 2136 3987= 3988 3998A h R*8 (82) VAR ARG 3802D 3937D 4084= 4093A 4099(2) 4102(2) 4117 i I*4 VAR AUTO 590 4 3946= 3947(2) 3948(2) 3949= 3954= 3955(2) 3956(2) 3957= 3963= 3964(3) 3965(2) 3966= 3972= 3973(2) 3974(2) 3975= 3999= 4000(2) 4001= 4039= 4040(2) 4041= 4061= 4062 4063 4064(2) 4065 4068(2) 4070= 4083= 4084(2) 4085= 4092= 4093(2) 4094= 4101= 4102(2) 4103= 4107= 4108(2) 4109= 4113(16)= 4117(4)= ic I*4 VAR AUTO 590 2144 3994= j I*4 VAR AUTO 590 3420 4062= 4063 4066 jprint I*4 (10) VAR COMMON 124 0 2-2D 2-3D 4012 4113 4117 kskip R*8 VAR COMMON 66 104 1-2D 1-4D l I*4 VAR AUTO 590 3096 4020= 4021(2) 4022= 4026= 4027(2) 4028= 4045= 4046(2) 4047= l1 I*4 VAR AUTO 590 2148 3995= 3997 3999 4017(4) 4019 4021(2) 4039 4046(2) l1m1 I*4 VAR AUTO 590 3092 4019= 4020 4045 l2 I*4 VAR AUTO 590 2152 3996= 3997 3999 4039 m I*4 VAR AUTO 590 2156 3997= 4090= 4092 4099(4) 4100 4102(2) mp1 I*4 VAR AUTO 590 3588 4100= 4101 numek R*8 VAR COMMON 66 96 1-2D 1-4D nx I*4 VAR AUTO 590 2140 3993= 3998A 4000A 4008A 4038A 4040A 4079A 4093A p0log R*8 VAR AUTO 590 3072 4007= 4008A p101 R*8 (101) VAR AUTO 590 1000 3934D 3955= 3956A p101lg R*8 (101) VAR AUTO 590 1808 3934D 3956= 4000A 4017(2) 4021(2) 4040A p11 R*8 (11) VAR AUTO 590 96 3934D 3947= 3948A 4006 4113(2) p11log R*8 (11) VAR AUTO 590 192 3934D 3948= 3986(2) 3998A 4000A 4008A 4038A 4040A 4060 4063 pi R*8 VAR COMMON 66 0 1-2D 1-4D plginv R*8 (11) VAR AUTO 590 3416 3937D 4060= 4063= 4064(2) 4079A 4093A pnot R*8 VAR ARG 3802D 4006 4007A ps R*8 (82) VAR ARG 3802D 3937D 4093A 4099(2) 4102(2)= 4108(2)= 4117 pscaleforg R*8 VAR COMMON 66 88 1-2D 1-4D r R*8 VAR COMMON 66 16 1-2D 1-4D 4057 r0 R*8 VAR AUTO 590 3232 4057= 4067(2) rinv R*8 VAR COMMON 66 24 1-2D 1-4D slope R*8 VAR AUTO 590 3088 4017= 4021 4099= 4102 sq2 R*8 VAR COMMON 66 40 1-2D 1-4D t R*8 VAR AUTO 590 3448 4066= 4067 t11ave R*8 (11) VAR AUTO 590 2080 3934D 3971= 3974= 4038A 4040A 4113(2) tmp10 R*8 (10) VAR ARG 3802D 3934D 3973 4066 4113 tmp101 R*8 (101) VAR ARG 3802D 3934D 4040A 4046(2)= tmptop R*8 VAR ARG 3802D 3970 3971 4113 tsum R*8 VAR AUTO 590 1992 3970= 3973(2)= 3974 x101 R*8 (101) VAR ARG 3802D 3934D 4027= x101lg R*8 (101) VAR AUTO 590 3064 3934D 4000A 4017(2) 4021(2)= 4027A x11 R*8 (11) VAR AUTO 590 1896 3934D 3961= 3962A 3964(2)= 3965A 3974 3987 4005 4113(2) x11log R*8 (11) VAR AUTO 590 1984 3934D 3962= 3965= 3985(2) 3998A 4000A 4008A xp0log R*8 VAR AUTO 590 3080 4008A 4010A xpnot R*8 VAR ARG 3802D 4005= 4010= 4012 xtop R*8 VAR ARG 3802D 3961 3970 4113 z R*8 VAR AUTO 590 3440 4065= 4067 z11 R*8 (11) VAR AUTO 590 3328 3937D 4059= 4065 4068(2)= 4079A 4090 4093A 4113(2) LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 3949 150 3975 195 4045 275 4041 345 4094 460 4109 6200 4121 20 3957 175 4001 200 4022 300 4047 400 4070 900 4118 6210 4126 110 3966 180 4011 250 4028 320 4085 450 4103 2000 4120 0004129 subroutine slant(h,ps,cofx,fracin,lmax,layer,pshold,hhold) 0004130 c 0004131 c*********************************************************************** 0004132 cccc 0004133 c subroutine slant 0004134 c 0004135 c purpose- 0004136 c 1. subdivide the layers of the standard atmosphere and 0004137 c calculate the scattering and total optical depths of the 0004138 c atmosphere from top to each layer. 0004139 c 2. using the above results calculate the chapman constants. 0004140 c 0004141 c method- 0004142 c 1. the layers are subdivided using exponential interpolation 0004143 c 2. the total o.d. are calculated using spline interpolation 0004144 c 0004145 c calling sequence- 0004146 c call slant(h,ps,cofx,fracin,juzsfr,lmax,layer) 0004147 c 0004148 c variable type i/o description 0004149 c -------- ---- --- ----------- 0004150 c 0004151 c h(487) r*8 i height of the layers above surface(km) 0004152 c o height from earth center(fraction of r) 0004153 c ps(487) r*8 i pressure at each layer (in atmosphere) 0004154 c o rayleigh opt. thickness of each layer 0004155 c of the standard atmosphere 0004156 c cofx(4,487) r*8 i spline interpolation coeff. 0004157 c fracin o layer*radius of earth(km) 0004158 c juzsfr i*4 i print flag 0004159 c lmax i*4 i no. of layers in standard atmosphere 0004160 c layer i*4 i no. of subdivisions to be made of each 0004161 c layer of the standard atmosphere 0004162 c other variables are returned thru common block 'chpmn' 0004163 c 0004164 c last modified 03/14/95...dave flittner 0004165 c purpose: set pressure scale height used in gravity correction 0004166 c to rayleigh scattering od. Create new variable pscaleforg and 0004167 c pass in common block consts. Perform gravity correction when 0004168 c computing rayleigh optical depth and storing in array ps. 0004169 c Also use logical switch lgcorrect 0004170 c to impliment the gravity correction to the rayleigh scattering 0004171 c optical depth. 0004172 c 0004173 cccc 0004174 implicit integer*4(i-n),real*8 (a-h,o-z) 0004175 real *8 h(487),ps(487),hhold(100),pshold(101), 0004176 1 cofx(4,487) 0004177 c 0004178 include "prints.inc" 0004179 include "consts.inc" 0004180 include "thkns.inc" 0004181 include "atmos.inc" 0004182 include "chpmn.inc" 0004183 include "cgcorrect.inc" 0004184 c 0004185 c*****use the ps and h that were saved before 0004186 c 0004187 80 do 82 i=1,lmax 0004188 h(i)=hhold(i) 0004189 82 ps(i)=pshold(i) 0004190 c 0004191 c*****renumber the layers to put layer 1 near the top of the atmos. 0004192 c***** (standard atmos. is read in a reverse order) 0004193 c 0004194 85 continue 0004195 lmaxd2 = lmax/2 0004196 do 100 i = 1, lmax 0004197 if(lgcorrect)then !def 0004198 ps(i) = beta*ps(i)*(1.0d0-pscaleforg*dlog(ps(i)))**2 !def 0004199 else !def 0004200 ps(i) = beta*ps(i) 0004201 endif !def 0004202 100 continue 0004203 do 110 i = 1, lmaxd2 0004204 k = lmax - i + 1 0004205 hold = h(i) 0004206 h(i) = h(k) 0004207 h(k) = hold 0004208 hold = ps(i) 0004209 ps(i) = ps(k) 0004210 110 ps(k) = hold 0004211 c 0004212 c*****subdivide the layers of std. atmos. by interpolation 0004213 c*****assume pressure dependence between the layers of the form 0004214 c***** p=pnot**(-h/hnot) 0004215 c 0004216 lmax = layer*(lmax - 1) + 1 0004217 lmaxm1 = lmax - 1 0004218 layrm1 = layer - 1 0004219 do 112 i = 1, lmax, layer 0004220 j = lmax - i + 1 0004221 k = j/layer + 1 0004222 h(j) = h(k) 0004223 112 ps(j) = ps(k) 0004224 frac = 1./float(layer) 0004225 fracin = r*float(layer) 0004226 lmaxml = lmax - layer 0004227 do 114 i = 1, lmaxml, layer 0004228 k = i + layer 0004229 dum = (ps(k)/ps(i))**frac 0004230 k = i 0004231 do 114 j = 1, layrm1 0004232 k = k + 1 0004233 h(k) = h(k-1) - frac 0004234 114 ps(k) = ps(i)*dum**j 0004235 c 0004236 c*****use spline interpol. to obtain total opt. depth of each layer 0004237 c***** in the standard atmosphere (xs) 0004238 c 0004239 j = 1 0004240 dum = dlog(ps(j)) 0004241 do 130 i = 2, 101 0004242 if (dum .gt. tsl(i)) go to 130 0004243 k = i - 1 0004244 120 dum1 = tsl(i) - dum 0004245 dum2 = dum - tsl(k) 0004246 dum3 = dum1*(cofx(1,k)*dum1**2 + cofx(3,k)) + dum2*(cofx(2,k)* 0004247 1dum2**2 + cofx(4,k)) 0004248 xs(j) = dexp(dum3) 0004249 j = j + 1 0004250 if (j .gt. lmax) go to 140 0004251 dum = dlog(ps(j)) 0004252 if (dum .le. tsl(i)) go to 120 0004253 130 continue 0004254 c 0004255 c*****calculate ps(rayleigh opt. thickness) and dxs(total opt. thick) 0004256 140 dxs(1) = xs(1) 0004257 holdc = ps(1) 0004258 do 150 i = 2, lmax 0004259 holdd = ps(i) 0004260 ps(i) = holdd - holdc 0004261 holdc = holdd 0004262 150 dxs(i) = xs(i) - xs(i-1) 0004263 do 160 i = 1, lmax 0004264 xs(i) = dlog(xs(i)) 0004265 160 h(i) = 1. + h(i)*rinv 0004266 if(jprint(7).ne.0) 0004267 1 write(33,6400)(h(i),ps(i),xs(i),dxs(i),i=1,lmax) 0004268 dum = r*h(1) 0004269 mm=20*layer+2 0004270 scalp=20./dlog(ps(mm)/ps(2)) 0004271 scalx = scalp 0004272 scalx=20./dlog((dxs(mm)-ps(mm))/(dxs(2)-ps(2))) 0004273 chp = dum/scalp*0.5 0004274 chx = dum/scalx*0.5 0004275 chpn = dsqrt(chp*pi) 0004276 chxn = dsqrt(chx*pi) 0004277 sqchp = dsqrt(chp) 0004278 sqchx = dsqrt(chx) 0004279 6400 format (1h1,2(5x,1hh,14x,2hps,14x,2hxs,13x,3hdxs,9x)/1h,/, 0004280 1 (1h ,2(f10.8, 3d16.4, 5x))) 0004281 return 0004282 end INCLUDE FILES FileNo File name 1 prints.inc 2 consts.inc 3 thkns.inc 4 atmos.inc 5 chpmn.inc 6 cgcorrect.inc ENTRY POINTS Name Type BlockNo slant SUBR 592 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References dexp INTRINSIC 4248 dlog INTRINSIC 4198 4240 4251 4264 4270 4272 dsqrt INTRINSIC 4275 4276 4277 4278 float INTRINSIC 4224 4225 slant SUBR 4129D COMMON BLOCKS Name Size BlockNo atmos_ 48 87 cgcorrect_ 4 92 chpmn_ 7824 300 consts_ 112 66 prints_ 40 124 thkns_ 8888 83 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References alpha0 R*8 VAR COMMON 87 0 4-2D 4-3D beta R*8 VAR COMMON 87 8 4-2D 4-3D 4198 4200 c1415 R*8 VAR COMMON 66 72 2-2D 2-4D c215 R*8 VAR COMMON 66 48 2-2D 2-4D c2815 R*8 VAR COMMON 66 80 2-2D 2-4D c38sq2 R*8 VAR COMMON 66 64 2-2D 2-4D c815 R*8 VAR COMMON 66 56 2-2D 2-4D chp R*8 VAR AUTO 592 176 4273= 4275 4277A chpn R*8 VAR COMMON 300 0 5-2D 5-3D 4275= chx R*8 VAR AUTO 592 184 4274= 4276 4278A chxn R*8 VAR COMMON 300 8 5-2D 5-3D 4276= cnvrt R*8 VAR COMMON 66 8 2-2D 2-4D code R*8 VAR COMMON 87 16 4-3D cofx R*8 (4,487) VAR ARG 4129D 4175D 4246(4) cons R*8 VAR COMMON 66 32 2-2D 2-4D dtsp R*8 (202) VAR COMMON 83 5656 3-2D 3-3D dtts R*8 (202) VAR COMMON 83 7272 3-2D 3-3D dum R*8 VAR AUTO 592 88 4229= 4234 4240= 4242 4244 4245 4251= 4252 4268= 4273 4274 dum1 R*8 VAR AUTO 592 104 4244= 4246(2) dum2 R*8 VAR AUTO 592 112 4245= 4246(2) dum3 R*8 VAR AUTO 592 120 4246= 4248A dxs R*8 (487) VAR COMMON 300 3928 5-2D 5-3D 4256= 4262= 4266 4272(2) frac R*8 VAR AUTO 592 72 4224= 4229 4233 fracin R*8 VAR ARG 4129D 4225= h R*8 (487) VAR ARG 4129D 4175D 4188= 4205 4206(2)= 4207= 4222(2)= 4233(2)= 4265(2)= 4266 4268 hhold R*8 (100) VAR ARG 4129D 4175D 4188 hold R*8 VAR AUTO 592 48 4205= 4207 4208= 4210 holdc R*8 VAR AUTO 592 136 4257= 4260 4261= holdd R*8 VAR AUTO 592 144 4259= 4260 4261 i I*4 VAR AUTO 592 4 4187= 4188(2) 4189(3)= 4196= 4198(3) 4200(2) 4202= 4203= 4204 4205 4206 4208 4209 4210= 4219= 4220 4223= 4227= 4228 4229 4230 4234(2)= 4241= 4242 4243 4244 4252 4253= 4258= 4259 4260 4262(4)= 4263= 4264(2) 4265(3)= 4266(6)= j I*4 VAR AUTO 592 64 4220= 4221 4222 4223 4231= 4234(2)= 4239= 4240 4248 4249(2)= 4250 4251 jprint I*4 (10) VAR COMMON 124 0 1-2D 1-3D 4266 k I*4 VAR AUTO 592 36 4204= 4206 4207 4209 4210 4221= 4222 4223 4228= 4229 4230= 4232(2)= 4233(2) 4234 4243= 4245 4246(4) kskip R*8 VAR COMMON 66 104 2-2D 2-4D layer I*4 VAR ARG 4129D 4216 4218 4219 4221 4224A 4225A 4226 4227 4228 4269 layrm1 I*4 VAR AUTO 592 56 4218= 4231 lgcorrect L*4 VAR COMMON 92 0 6-2D 6-3D 4197 lmax I*4 VAR ARG 4129D 4187 4195 4196 4204 4216(2)= 4217 4219 4220 4226 4250 4258 4263 4266 lmaxd2 I*4 VAR AUTO 592 12 4195= 4203 lmaxm1 I*4 VAR AUTO 592 52 4217= lmaxml I*4 VAR AUTO 592 76 4226= 4227 mm I*4 VAR AUTO 592 148 4269= 4270 4272(2) numek R*8 VAR COMMON 66 96 2-2D 2-4D pi R*8 VAR COMMON 66 0 2-2D 2-4D 4275 4276 pnot R*8 VAR COMMON 87 24 4-2D 4-3D ps R*8 (487) VAR ARG 4129D 4175D 4189= 4198(3)= 4200(2)= 4208 4209(2)= 4210= 4223(2)= 4229(2) 4234(2)= 4240A 4251A 4257 4259 4260= 4266 4270(2) 4272(2) pscaleforg R*8 VAR COMMON 66 88 2-2D 2-4D 4198 pshold R*8 (101) VAR ARG 4129D 4175D 4189 r R*8 VAR COMMON 66 16 2-2D 2-4D 4225 4268 rinv R*8 VAR COMMON 66 24 2-2D 2-4D 4265 scalp R*8 VAR AUTO 592 160 4270= 4271 4273 scalx R*8 VAR AUTO 592 168 4271= 4272= 4274 sq2 R*8 VAR COMMON 66 40 2-2D 2-4D sqchp R*8 VAR COMMON 300 16 5-2D 5-3D 4277= sqchx R*8 VAR COMMON 300 24 5-2D 5-3D 4278= tautot R*8 VAR COMMON 87 32 4-2D 4-3D tsl R*8 (101) VAR COMMON 83 0 3-2D 3-3D 4242 4244 4245 4252 tt R*8 (202) VAR COMMON 83 808 3-2D 3-3D ttl R*8 (202) VAR COMMON 83 4040 3-2D 3-3D tts R*8 (202) VAR COMMON 83 2424 3-2D 3-3D wavelen R*8 VAR COMMON 87 40 4-2D 4-3D xs R*8 (487) VAR COMMON 300 32 5-2D 5-3D 4248= 4256 4262(2) 4264(2)= 4266 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 80 4187 85 4194 110 4210 114 4234 130 4253 150 4262 6400 4279 82 4189 100 4202 112 4223 120 4244 140 4256 160 4265 0004283 subroutine spline(x,y,n,yp1,ypn,y2) 0004284 c author: c seftor 0004285 c date: 3 feb 1991 0004286 c purpose: given arrays x and y of length n containing a tabulated 0004287 c function, and given values yp1 and ypn for the first derivative of 0004288 c the interpolating function at points 1 and n, respectively, this 0004289 c routinereturns an array y2 of length n which contains the second 0004290 c derivatives of the interpolating function at the tabulated value 0004291 c points x. if yp1 and/or ypn are equal to 1 x 10**30 or larger, 0004292 c routine is signalled to set the corresponding boundary condition for 0004293 c a natural spline, with zero second derivative on the boundary. 0004294 c (algorithm taken from numerical recipes (fortran), press et. al.) 0004295 c 0004296 implicit integer*4(i-n), real*8(a-h,o-z) 0004297 parameter (nmax=487) 0004298 real*8 x(n), y(n), y2(n), u(nmax) 0004299 real*8 yp1, ypn 0004300 integer*4 n 0004301 if (yp1 .gt. .99d30) then 0004302 y2(1) = 0. 0004303 u(1) = 0. 0004304 else 0004305 y2(1) = -0.5 0004306 u(1) = (3./(x(2)-x(1))) * ((y(2)-y(1))/(x(2)-x(1)) - yp1) 0004307 endif 0004308 do 11 i = 2,n-1 0004309 sig = (x(i)-x(i-1))/(x(i+1)-x(i-1)) 0004310 p = sig * y2(i-1) + 2. 0004311 y2(i) = (sig-1.)/p 0004312 u(i) = (6.*((y(i+1)-y(i))/(x(i+1)-x(i)) - (y(i)-y(i-1)) 0004313 1 /(x(i)-x(i-1)))/(x(i+1)-x(i-1)) - sig*u(i-1)) / p 0004314 11 continue 0004315 if (ypn .gt. .99d30) then 0004316 qn = 0. 0004317 un = 0. 0004318 else 0004319 qn = 0.5 0004320 un = (3./(x(n)-x(n-1))) * (ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) 0004321 endif 0004322 y2(n) = (un - qn*u(n-1))/(qn*y2(n-1)+1.) 0004323 do 12 k = n-1,1,-1 0004324 y2(k) = y2(k) * y2(k+1) + u(k) 0004325 12 continue 0004326 return 0004327 end ENTRY POINTS Name Type BlockNo spline SUBR 759 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References spline SUBR 4283D PARAMETERS Name Type References nmax I*4 4297D 4298 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References i I*4 VAR AUTO 759 3916 4308= 4309(4) 4310 4311 4312(12) 4314= k I*4 VAR AUTO 759 3956 4323= 4324(4) 4325= n I*4 VAR ARG 4283D 4298(3)D 4300D 4308 4320(6) 4322(3) 4323 4327(3) p R*8 VAR AUTO 759 3936 4310= 4311 4312 qn R*8 VAR AUTO 759 3944 4316= 4319= 4322(2) sig R*8 VAR AUTO 759 3928 4309= 4310 4311 4312 u R*8 (487) VAR AUTO 759 3912 4298D 4303= 4306= 4312(2)= 4322 4324 un R*8 VAR AUTO 759 3952 4317= 4320= 4322 x R*8 (*) VAR ARG 4283D 4298D 4306(4) 4309(4) 4312(6) 4320(4) y R*8 (*) VAR ARG 4283D 4298D 4306(2) 4312(4) 4320(2) y2 R*8 (*) VAR ARG 4283D 4298D 4302= 4305= 4310 4311= 4322(2)= 4324(3)= yp1 R*8 VAR ARG 4283D 4299D 4301 4306 ypn R*8 VAR ARG 4283D 4299D 4315 4320 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 11 4314 12 4325 0004328 subroutine splint(xa,ya,y2a,n,x,y) 0004329 c author: c. seftor 0004330 c date: 3 feb 1991 0004331 c purpose: given the arrays xa and ya of length n, which tabulate a 0004332 c function (with the xa's in order), and given the array y2a, 0004333 c which is the output from the subroutine spline, and given a value 0004334 c of x, this routine returns a cubic-spline interpolated value y. 0004335 c (algorithm taken from numerical recipes (fortran) by press et. al.) 0004336 c 0004337 implicit integer*4(i-n), real*8(a-h,o-z) 0004338 real*8 xa(n), ya(n), y2a(n), x, y 0004339 real*8 a, b 0004340 integer*4 n 0004341 klo = 1 0004342 khi = n 0004343 10 continue 0004344 if (khi-klo .gt. 1) then 0004345 k = (khi+klo)/2 0004346 if (xa(k) .gt. x) then 0004347 khi = k 0004348 else 0004349 klo = k 0004350 endif 0004351 goto 10 0004352 endif 0004353 h = xa(khi) - xa(klo) 0004354 if (h .eq. 0.) then 0004355 write (23,*)' bad xa input' 0004356 stop 0004357 endif 0004358 a = (xa(khi)-x)/h 0004359 b = (x-xa(klo))/h 0004360 y = a*ya(klo) + b*ya(khi) + 0004361 1 ((a**3-a)*y2a(klo) + (b**3-b)*y2a(khi)) * (h**2)/6. 0004362 return 0004363 end ENTRY POINTS Name Type BlockNo splint SUBR 762 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References splint SUBR 4328D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 VAR AUTO 762 40 4339D 4358= 4360(3) b R*8 VAR AUTO 762 48 4339D 4359= 4360(3) h R*8 VAR AUTO 762 32 4353= 4354 4358 4359 4360 k I*4 VAR AUTO 762 24 4345= 4346 4347 4349 khi I*4 VAR AUTO 762 20 4342= 4344 4345 4347= 4353 4358 4360(2) klo I*4 VAR AUTO 762 16 4341= 4344 4345 4349= 4353 4359 4360(2) n I*4 VAR ARG 4328D 4338(3)D 4340D 4342 4363(3) x R*8 VAR ARG 4328D 4338D 4346 4358 4359 xa R*8 (*) VAR ARG 4328D 4338D 4346 4353(2) 4358 4359 y R*8 VAR ARG 4328D 4338D 4360= y2a R*8 (*) VAR ARG 4328D 4338D 4360(2) ya R*8 (*) VAR ARG 4328D 4338D 4360(2) LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 10 4343 0004364 subroutine splset(x,y,c,m) 0004365 c*********************************************************************** 0004366 c 0004367 c this subroutine was taken from_ 0004368 c introductory computer methods and numerical analysisby 0004369 c ralph h. pennington 0004370 c the mcmillan company -newyork 1965. 0004371 c this subroutine will accept up to 487 points. 0004372 c 0004373 c***** x = independent variable 0004374 c***** y = dependent variable 0004375 c***** m = number of data points in the x and y arrays 0004376 c***** c = coefficents of the cubic that is fit between adjacent data po 0004377 c***** the following dimensions must be .ge. m 0004378 c*********************************************************************** 0004379 implicit integer*4(i-n),real*8 (a-h,o-z) 0004380 real*8 d(487), p(487), e(487), a(487,3), b(487), z(487) 0004381 real*8 x(1),y(1),c(4,1) 0004382 mm=m-1 0004383 do 2 k=1,mm 0004384 d(k)=x(k+1)-x(k) 0004385 p(k)=d(k)/6. 0004386 2 e(k)=(y(k+1)-y(k))/d(k) 0004387 do 3 k=2,mm 0004388 3 b(k)=e(k)-e(k-1) 0004389 a(1,2)=-1.-d(1)/d(2) 0004390 a(1,3)=d(1)/d(2) 0004391 a(2,3)=p(2)-p(1)*a(1,3) 0004392 a(2,2)=2.*(p(1)+p(2))-p(1)*a(1,2) 0004393 a(2,3)=a(2,3)/a(2,2) 0004394 b(2)=b(2)/a(2,2) 0004395 do 4 k=3,mm 0004396 a(k,2)=2.*(p(k-1)+p(k))-p(k-1)*a(k-1,3) 0004397 b(k)=b(k)-p(k-1)*b(k-1) 0004398 a(k,3)=p(k)/a(k,2) 0004399 4 b(k)=b(k)/a(k,2) 0004400 q=d(m-2)/d(m-1) 0004401 a(m,1)=1.+q+a(m-2,3) 0004402 a(m,2)=-q-a(m,1)*a(m-1,3) 0004403 b(m)=b(m-2)-a(m,1)*b(m-1) 0004404 z(m)=b(m)/a(m,2) 0004405 mn=m-2 0004406 do 6 i=1,mn 0004407 k=m-i 0004408 6 z(k)=b(k)-a(k,3)*z(k+1) 0004409 z(1)=-a(1,2)*z(2)-a(1,3)*z(3) 0004410 do 7 k=1,mm 0004411 q=1./(6.*d(k)) 0004412 c(1,k)=z(k)*q 0004413 c(2,k)=z(k+1)*q 0004414 c(3,k)=y(k)/d(k)-z(k)*p(k) 0004415 7 c(4,k)=y(k+1)/d(k)-z(k+1)*p(k) 0004416 return 0004417 end ENTRY POINTS Name Type BlockNo splset SUBR 315 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References splset SUBR 4364D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (487,3) VAR AUTO 315 27288 4380D 4389= 4390= 4391(2)= 4392(2)= 4393(3)= 4394 4396(2)= 4398(2)= 4399 4401(2)= 4402(3)= 4403 4404 4408 4409(2) b R*8 (487) VAR AUTO 315 15600 4380D 4388= 4394(2)= 4397(3)= 4399(2)= 4403(3)= 4404 4408 c R*8 (4,1) VAR ARG 4364D 4381D 4412= 4413= 4414= 4415= d R*8 (487) VAR AUTO 315 3912 4380D 4384= 4385 4386 4389(2) 4390(2) 4400(2) 4411 4414 4415 e R*8 (487) VAR AUTO 315 11704 4380D 4386= 4388(2) i I*4 VAR AUTO 315 31200 4406= 4407 4408= k I*4 VAR AUTO 315 8 4383= 4384(3) 4385(2) 4386(5)= 4387= 4388(4)= 4395= 4396(5) 4397(4) 4398(3) 4399(4)= 4407= 4408(4) 4410= 4411 4412(2) 4413(2) 4414(5) 4415(6)= m I*4 VAR ARG 4364D 4382 4400(2) 4401(2) 4402(3) 4403(4) 4404(3) 4405 4407 mm I*4 VAR AUTO 315 4 4382= 4383 4387 4395 4410 mn I*4 VAR AUTO 315 31196 4405= 4406 p R*8 (487) VAR AUTO 315 7808 4380D 4385= 4391(2) 4392(3) 4396(3) 4397 4398 4414 4415 q R*8 VAR AUTO 315 27296 4400= 4401 4402 4411= 4412 4413 x R*8 (1) VAR ARG 4364D 4381D 4384(2) y R*8 (1) VAR ARG 4364D 4381D 4386(2) 4414 4415 z R*8 (487) VAR AUTO 315 31192 4380D 4404= 4408(2)= 4409(3)= 4412 4413 4414 4415 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 2 4386 3 4388 4 4399 6 4408 7 4415 0004418 c 0004419 subroutine sumry(jmuz) 0004420 c************************************************************************ 0004421 c subroutine sumry prints out sb, t, i0 pol etc 0004422 c************************************************************************ 0004423 c 0004424 implicit real*8(a-h,o-z),integer*4(i-n) 0004425 c 0004426 include "contrl.inc" 0004427 include "out.inc" 0004428 include "totals.inc" 0004429 include "emm.inc" 0004430 include "atmos.inc" 0004431 include "in.inc" 0004432 include "buff1.inc" 0004433 include "buff2.inc" 0004434 include "buff3.inc" 0004435 include "buff4.inc" 0004436 include "depolt.inc" 0004437 c 0004438 maxpp=itmax+2 0004439 c 0004440 c write(9,50) 0004441 do i=1,maxpp 0004442 do j=1,imu 0004443 do k=1,iazmth 0004444 c write(9,100)i,thta(j),azmth(k),e0za(i,j),e1za(i,j,k), 0004445 c 1 e2za(i,j,k),ttz(i,j),sbz(i),ggz(i) 0004446 enddo 0004447 enddo 0004448 enddo 0004449 c 0004450 write(9,150)thnot(jmuz),wavlen 0004451 write(9,200) 0004452 do i=1,nalb 0004453 c do j=1,imu 0004454 c do k=1,iazmth 0004455 do k=1,iazmth 0004456 do j=1,imu 0004457 write(9,225)thta(j),azmth(k),eittl(j,k,i), 0004458 1 eittr(j,k,i),eitotz(j,k,i),polz(j,k,i),alb(i) 0004459 enddo 0004460 enddo 0004461 enddo 0004462 c 0004463 return 0004464 c 0004465 50 format(t2,'itr',t10,'the',t15,'phi',t26,'ei0',t37,'ei1', 0004466 1 t48,'ei2',t59,'t ',t67,'sb',t77,'gg') 0004467 100 format(i5,1x,f7.1,1x,f7.1,1p4e11.3,0pf8.5,1pe11.3) 0004468 150 format('solar zenith angle=',f6.1,' wavelength=',f7.1) 0004469 200 format(t4,'the',t12,'phi',t24,'eil',t35,'eir',t44,'eitot', 0004470 1 t55,'pol',t62,'alb') 0004471 225 format(f7.1,1x,f7.1,1x,1p3e11.3,0pf11.3,0pf7.3) 0004472 c 0004473 end INCLUDE FILES FileNo File name 1 contrl.inc 2 out.inc 3 totals.inc 4 emm.inc 5 atmos.inc 6 in.inc 7 buff1.inc 8 buff2.inc 9 buff3.inc 10 buff4.inc 11 depolt.inc ENTRY POINTS Name Type BlockNo sumry SUBR 222 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References sumry SUBR 4419D COMMON BLOCKS Name Size BlockNo atmos_ 48 87 buff1_ 1392 166 buff2_ 18432 128 buff3_ 3120 188 buff4_ 43320 444 contrl_ 2808 85 depolt_ 68 70 emm_ 1176 105 in_ 196 126 out_ 3256 117 totals_ 11968 435 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References admatx R*8 (3,15) VAR COMMON 105 360 4-2D 4-4D alb R*8 (11) VAR COMMON 85 200 1-3D 1-5D 4457 alfaef R*8 VAR COMMON 85 2792 1-5D alpha0 R*8 VAR COMMON 87 0 5-2D 5-3D azmth R*8 (8) VAR COMMON 85 136 1-3D 1-5D 4457 beta R*8 VAR COMMON 87 8 5-2D 5-3D caz R*8 (8) VAR COMMON 105 784 4-2D 4-4D caz2 R*8 (8) VAR COMMON 105 912 4-2D 4-4D code R*8 VAR COMMON 87 16 5-3D delp R*8 VAR COMMON 70 40 11-3D 11-4D delx R*8 (10) VAR COMMON 126 0 6-2D 6-4D e0za R*8 (9,15) VAR COMMON 128 0 8-2D 8-3D e1za R*8 (9,15,8) VAR COMMON 128 1080 8-2D 8-3D e2za R*8 (9,15,8) VAR COMMON 128 9720 8-2D 8-3D eiaz1 R*8 (15,8) VAR COMMON 117 360 2-2D 2-3D eiaz2 R*8 (15,8) VAR COMMON 117 1320 2-2D 2-3D eitl R*8 (15,8) VAR COMMON 188 0 9-2D 9-3D eitotz R*8 (15,8,11) VAR COMMON 444 21120 10-2D 10-3D 4457 eitr R*8 (15,8) VAR COMMON 188 960 9-2D 9-3D eittl R*8 (15,8,11) VAR COMMON 444 0 10-2D 10-3D 4457 eittr R*8 (15,8,11) VAR COMMON 444 10560 10-2D 10-3D 4457 eitu R*8 (15,8) VAR COMMON 188 1920 9-2D 9-3D eizero R*8 (15) VAR COMMON 117 240 2-2D 2-3D ematx R*8 (3,15) VAR COMMON 105 0 4-2D 4-4D emu R*8 (15) VAR COMMON 105 976 4-2D 4-4D emuz R*8 (10) VAR COMMON 105 1096 4-2D 4-4D fs R*8 VAR COMMON 117 2288 2-2D 2-3D gama R*8 VAR COMMON 70 8 11-3D 11-4D gg R*8 VAR COMMON 117 2280 2-2D 2-3D ggz R*8 (9) VAR COMMON 128 18360 8-2D 8-3D hhold R*8 (101) VAR COMMON 85 1904 1-3D 1-5D i I*4 VAR AUTO 222 8 4441= 4448= 4452= 4457(5) 4461= iazmth I*4 VAR COMMON 85 12 1-2D 1-5D 4443 4455 imu I*4 VAR COMMON 85 4 1-2D 1-5D 4442 4456 imuz I*4 VAR COMMON 85 8 1-2D 1-5D ipath I*4 VAR COMMON 126 192 6-3D 6-4D ipol I*4 VAR COMMON 70 64 11-2D 11-4D ipsudo I*4 VAR COMMON 126 188 6-3D 6-4D itmax I*4 VAR COMMON 126 184 6-3D 6-4D 4438 j I*4 VAR AUTO 222 16 4442= 4447= 4456= 4457(5) 4459= jmuz I*4 VAR ARG 4419D 4450 k I*4 VAR AUTO 222 24 4443= 4446= 4455= 4457(5) 4460= lambda I*4 VAR COMMON 85 2800 1-2D 1-5D layer I*4 VAR COMMON 85 2804 1-2D 1-5D maxpp I*4 VAR AUTO 222 4 4438= 4441 nalb I*4 VAR COMMON 85 0 1-2D 1-5D 4452 pnot R*8 VAR COMMON 87 24 5-2D 5-3D polz R*8 (15,8,11) VAR COMMON 444 31680 10-2D 10-3D 4457 pshold R*8 (101) VAR COMMON 85 1096 1-3D 1-5D q R*8 VAR COMMON 70 16 11-3D 11-4D q1 R*8 VAR COMMON 70 24 11-3D 11-4D q12s R*8 VAR COMMON 70 56 11-3D 11-4D q2 R*8 VAR COMMON 70 32 11-3D 11-4D qr R*8 (11) VAR COMMON 117 32 2-2D 2-3D rhon R*8 VAR COMMON 70 0 11-3D 11-4D ristar R*8 (15,11) VAR COMMON 435 0 3-2D 3-3D saz R*8 (8) VAR COMMON 105 720 4-2D 4-4D saz2 R*8 (8) VAR COMMON 105 848 4-2D 4-4D sb R*8 (4) VAR COMMON 117 0 2-2D 2-3D sbz R*8 (9) VAR COMMON 166 0 7-2D 7-3D sdp R*8 VAR COMMON 70 48 11-3D 11-4D tautot R*8 VAR COMMON 87 32 5-2D 5-3D tensig R*8 (11) VAR COMMON 435 1320 3-2D 3-3D thnot R*8 (10) VAR COMMON 85 2712 1-3D 1-5D 4450 thta R*8 (15) VAR COMMON 85 16 1-3D 1-5D 4457 tmp0 R*8 VAR COMMON 126 176 6-2D 6-4D tmp10 R*8 (10) VAR COMMON 126 88 6-2D 6-4D tmptop R*8 VAR COMMON 126 168 6-2D 6-4D tnstr R*8 (15) VAR COMMON 117 120 2-2D 2-3D tnstrl R*8 (15) VAR COMMON 166 1152 7-2D 7-3D tnstrr R*8 (15) VAR COMMON 166 1272 7-2D 7-3D tnstrz R*8 (9,15) VAR COMMON 166 72 7-2D 7-3D total R*8 (15,8,11) VAR COMMON 435 1408 3-2D 3-3D totint R*8 (15,8) VAR COMMON 117 2296 2-2D 2-3D ttlp R*8 (15) VAR COMMON 188 2880 9-2D 9-3D ttrp R*8 (15) VAR COMMON 188 3000 9-2D 9-3D ttz R*8 (9,15) VAR COMMON 444 42240 10-2D 10-3D wavelen R*8 VAR COMMON 87 40 5-2D 5-3D wavlen R*8 VAR AUTO 222 40 4450 x R*8 (101) VAR COMMON 85 288 1-3D 1-5D xtop R*8 VAR COMMON 126 80 6-2D 6-4D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 50 4465 100 4467 150 4468 200 4469 225 4471 0004474 subroutine tbprnt(thenot) 0004475 c 0004476 implicit real*8(a-h,o-z),integer*4(i-n) 0004477 real*8 thenot 0004478 c 0004479 include "contrl.inc" 0004480 include "out.inc" 0004481 include "totals.inc" 0004482 include "prints.inc" 0004483 c 0004484 c if(thenot.ne.thnot(1)) go to 50 0004485 c 0004486 c**** print current solar zenith angle,fractional back 0004487 c**** scatter factor and qr values for each albedo. 0004488 c 0004489 if (jprint(8) .eq. 1) write(33,1000) thenot,sb(4), 0004490 * (qr(i),i=1,nalb) 0004491 c 0004492 c**** print istar/ig at top of atmosphere. 0004493 c 0004494 if (jprint(8) .eq. 1) write(33,1100) 0004495 * (i,thta(i),tnstr(i),i=1,imu) 0004496 c 0004497 c 50 continue 0004498 c 0004499 c**** print azimuth independent terms for scattered rad. 0004500 c 0004501 if (jprint(8) .eq. 1) write(33,1200) thenot,fs, 0004502 * gg,(i,thta(i),eizero(i),i=1,imu) 0004503 c 0004504 c**** write eiaz1 heading 0004505 c 0004506 if (jprint(8) .eq. 1) write(33,2000) thenot, 0004507 * (azmth(i),i=1,iazmth) 0004508 c 0004509 c**** print eiaz1 (cos(phi) azimuth dependent term) 0004510 c 0004511 do 100 i=1,imu 0004512 c 0004513 if (jprint(8) .eq. 1) write(33,2100) thta(i), 0004514 * (eiaz1(i,j),j=1,iazmth) 0004515 100 continue 0004516 c 0004517 c**** print eiaz2 heading 0004518 c 0004519 if (jprint(8) .eq. 1) write(33,2200) thenot, 0004520 * (azmth(j),j=1,iazmth) 0004521 c 0004522 c**** print eiaz2 (cos(2*phi) dependent term) 0004523 c 0004524 do 200 i=1,imu 0004525 c 0004526 if (jprint(8) .eq. 1) write(33,2100) thta(i), 0004527 * (eiaz2(i,j),j=1,iazmth) 0004528 200 continue 0004529 c 0004530 c**** print istar total ground reflected radiation at top 0004531 c**** of atmosphere. 0004532 c 0004533 c inc=nalb-1 0004534 do 400 k=1,nalb 0004535 if (jprint(8) .eq. 1) write(33,3200) alb(k) 0004536 if (jprint(8) .eq. 1) write(33,3300) (ristar(i,k),i=1,imu) 0004537 c 0004538 c **** print total intensity izero+i1+i2+istar at top 0004539 c **** of atmosphere for each albedo and polar look angle. 0004540 c 0004541 if (jprint(8) .eq. 1) write(33,3400) thenot,alb(k), 0004542 * (azmth(m),m=1,iazmth) 0004543 do 500 i=1,imu 0004544 if (jprint(8) .eq. 1) write(33,2100) thta(i), 0004545 * (total(i,j,k),j=1,iazmth) 0004546 500 continue 0004547 400 continue 0004548 return 0004549 1000 format (1h1,t50,'thnot= ',f6.2,///,1x,'sb(4)= ', 0004550 1 4x,(d12.6,1x),//,1x,'qr(11)= ',/, 0004551 2 2(13x,5(d12.6,1x),d12.6,/)) 0004552 c 0004553 1100 format (5x,'theta ',5x,' tenstr',//,(1x,i2,3x,f6.2,2x,d12.6)) 0004554 1200 format(///,1x,'azimuth angle independent data for thenot= ', 0004555 1 f6.2,//,1x,'fs= ',d12.6,5x,'gg= ',d12.6,//, 0004556 2 5x,'theta',5x,'eizero',/, 0004557 3 (1x,i2,2x,f6.2,2x,d12.6)) 0004558 c 0004559 2000 format(//,11x,'theta/phi table for eiaz1 term', 0004560 1 10x,'thenot= ',f6.2,//, 0004561 2 1x,'theta',/,10x,8(f6.2,7x)) 0004562 c 0004563 2100 format(1x,f6.2,8(1x,d12.6)) 0004564 c 0004565 2200 format(//,11x,'theta/phi table for eiaz2 term', 0004566 1 10x,'thenot= ',f6.2,//, 0004567 2 1x,'theta',/,10x,8(f6.2,7x)) 0004568 c 0004569 3000 format(/,' albedo= ',11(f4.2,1x)) 0004570 c 0004571 c 0004572 3200 format(/,' albedo= ',f4.2) 0004573 c 0004574 3300 format(/,' istar-- total reflected intensity for ', 0004575 1 'current albedo and polar look angles',/, 0004576 2 ' ristar(15,11)= ',/,3(15x,5(d12.6,1x),/)) 0004577 3400 format(//,11x,'theta/phi table for total intensity', 0004578 1 ' for thenot= ',f6.2,' and albedo= ',f4.2,//, 0004579 2 1x,'theta ',/,10x,8(f6.2,7x)) 0004580 end INCLUDE FILES FileNo File name 1 contrl.inc 2 out.inc 3 totals.inc 4 prints.inc ENTRY POINTS Name Type BlockNo tbprnt SUBR 604 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References tbprnt SUBR 4474D COMMON BLOCKS Name Size BlockNo contrl_ 2808 85 out_ 3256 117 prints_ 40 124 totals_ 11968 435 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References alb R*8 (11) VAR COMMON 85 200 1-3D 1-5D 4535 4541 alfaef R*8 VAR COMMON 85 2792 1-5D azmth R*8 (8) VAR COMMON 85 136 1-3D 1-5D 4506 4519 4541 eiaz1 R*8 (15,8) VAR COMMON 117 360 2-2D 2-3D 4513 eiaz2 R*8 (15,8) VAR COMMON 117 1320 2-2D 2-3D 4526 eizero R*8 (15) VAR COMMON 117 240 2-2D 2-3D 4501 fs R*8 VAR COMMON 117 2288 2-2D 2-3D 4501 gg R*8 VAR COMMON 117 2280 2-2D 2-3D 4501 hhold R*8 (101) VAR COMMON 85 1904 1-3D 1-5D i I*4 VAR AUTO 604 4 4489(2) 4494(5)= 4501(5)= 4506(2) 4511= 4513(2) 4515= 4524= 4526(2) 4528= 4536(2) 4543= 4544(2) 4546= iazmth I*4 VAR COMMON 85 12 1-2D 1-5D 4506(2) 4513 4519(2) 4526 4541(2) 4544 imu I*4 VAR COMMON 85 4 1-2D 1-5D 4494 4501 4511 4524 4536(2) 4543 imuz I*4 VAR COMMON 85 8 1-2D 1-5D j I*4 VAR AUTO 604 12 4513(3)= 4519(2) 4526(3)= 4544(3)= jprint I*4 (10) VAR COMMON 124 0 4-2D 4-3D 4489 4494 4501 4506 4513 4519 4526 4535 4536 4541 4544 k I*4 VAR AUTO 604 20 4534= 4535 4536 4541 4544 4547= lambda I*4 VAR COMMON 85 2800 1-2D 1-5D layer I*4 VAR COMMON 85 2804 1-2D 1-5D m I*4 VAR AUTO 604 24 4541(2) nalb I*4 VAR COMMON 85 0 1-2D 1-5D 4489(2) 4534 pshold R*8 (101) VAR COMMON 85 1096 1-3D 1-5D qr R*8 (11) VAR COMMON 117 32 2-2D 2-3D 4489 ristar R*8 (15,11) VAR COMMON 435 0 3-2D 3-3D 4536 sb R*8 (4) VAR COMMON 117 0 2-2D 2-3D 4489 tensig R*8 (11) VAR COMMON 435 1320 3-2D 3-3D thenot R*8 VAR ARG 4474D 4477D 4489 4501 4506 4519 4541 thnot R*8 (10) VAR COMMON 85 2712 1-3D 1-5D thta R*8 (15) VAR COMMON 85 16 1-3D 1-5D 4494 4501 4513 4526 4544 tnstr R*8 (15) VAR COMMON 117 120 2-2D 2-3D 4494 total R*8 (15,8,11) VAR COMMON 435 1408 3-2D 3-3D 4544 totint R*8 (15,8) VAR COMMON 117 2296 2-2D 2-3D x R*8 (101) VAR COMMON 85 288 1-3D 1-5D LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 4515 400 4547 1000 4549 1200 4554 2100 4563 3000 4569 3300 4574 200 4528 500 4546 1100 4553 2000 4559 2200 4565 3200 4572 3400 4577 +--------------------------------------------+ | : Referenced but not modified | | = : Value modified | | A : Actual argument, possibly modified | | D : Declared/Defined | | I : Data Initialization | | (n) : Number of occurrences | | # : Unknown usage | +--------------------------------------------+