OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
crftgcr.f
Go to the documentation of this file.
1  subroutine crftgcr
2 c
3 c apply geometric correction to the stokes parameters of the diffuse
4 c radiation at atmospheric levels bracketing the aircraft levels
5 c
6 c**********************************************************************
7 c
8  implicit real*8 (a-h,o-z)
9  include 'afrt_rt2.cmn'
10 c
11 c**********************************************************************
12 c
13  m1=jpass-2
14  m2=jpass-1
15  m3=jpass
16 c
17 c apply geo. series correction to fluxes and radiances leaving aircraft
18 c level lvlcrft1
19 c
20  read(73,rec=m3)ftmp
21  read(73,rec=m2)ftmpa
22  read(73,rec=m1)ftmpb
23 c
24  call fluxlvl(ftmpb,crftd1(1),0)
25  call fluxlvl(ftmpb,crftu1(1),1)
26  call fluxlvl(ftmpa,crftd1(2),0)
27  call fluxlvl(ftmpa,crftu1(2),1)
28  call fluxlvl(ftmp,crftd1(3),0)
29  call fluxlvl(ftmp,crftu1(3),1)
30 c
31  call geom(crftd1(1),crftd1(2),crftd1(3),crr1,crftd1(4))
32  call geom(crftu1(1),crftu1(2),crftu1(3),crr1,crftu1(4))
33 c
34  do i=1,(nx-1)
35  do j=1,jpart
36  do k=1,4
37  if(ftmp(k,i,j).le.1.0d-15)then
38  fiolvl1(k,i,j)=ftmp(k,i,j)
39  else
40  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
41  1 crftrd1,fiolvl1(k,i,j))
42  endif
43  enddo
44  enddo
45  enddo
46 c
47  do i=nx,nmum1
48  do j=1,jpart
49  do k=1,4
50  if(ftmp(k,i,j).le.1.0d-15)then
51  fiolvl1(k,i,j)=ftmp(k,i,j)
52  else
53  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
54  1 crftru1,fiolvl1(k,i,j))
55  endif
56  enddo
57  enddo
58  enddo
59 c
60  read(74,rec=m3)ftmp
61  read(74,rec=m2)ftmpa
62  read(74,rec=m1)ftmpb
63 c
64 c
65  call fluxlvl(ftmpb,crftd2(1),0)
66  call fluxlvl(ftmpb,crftu2(1),1)
67  call fluxlvl(ftmpa,crftd2(2),0)
68  call fluxlvl(ftmpa,crftu2(2),1)
69  call fluxlvl(ftmp,crftd2(3),0)
70  call fluxlvl(ftmp,crftu2(3),1)
71 c
72  call geom(crftd2(1),crftd2(2),crftd2(3),crr2,crftd2(4))
73  call geom(crftu2(1),crftu2(2),crftu2(3),crr2,crftu2(4))
74 c
75  do i=1,(nx-1)
76  do j=1,jpart
77  do k=1,4
78  if(ftmp(k,i,j).le.1.0d-15)then
79  fiolvl2(k,i,j)=ftmp(k,i,j)
80  else
81  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
82  1 crftrd2,fiolvl2(k,i,j))
83  endif
84  enddo
85  enddo
86  enddo
87 c
88  do i=nx,nmum1
89  do j=1,jpart
90  do k=1,4
91  if(ftmp(k,i,j).le.1.0d-15)then
92  fiolvl2(k,i,j)=ftmp(k,i,j)
93  else
94  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
95  1 crftru2,fiolvl2(k,i,j))
96  endif
97  enddo
98  enddo
99  enddo
100 c
101 c interpolate the fluxes and radiances at the aircraft height
102 c
103  call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),crftd1(4),
104  1 crftd2(4),crftfd)
105  call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),crftu1(4),
106  1 crftu2(4),crftfu)
107 c
108  do i=1,nmum1
109  do j=1,jpart
110  do k=1,4
111  call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),
112  1 fiolvl1(k,i,j),fiolvl2(k,i,j),fiocrft(k,i,j))
113  enddo
114  enddo
115  enddo
116 c
117 c
118  if(kzz.eq.1)then
119  call crftout
120 c
121  cfdown(ksza)=crftfd*pi
122  cfup(ksza)=crftfu*pi
123  do i=1,(nx-1)
124  do j=1,jpart
125  crftzd(ksza,i,j)=fiocrft(1,i,j)+fiocrft(2,i,j)
126  enddo
127  enddo
128  do i=nx,nmum1
129  m=nmum1-i+1
130  do j=1,jpart
131  crftzu(ksza,m,j)=fiocrft(1,i,j)+fiocrft(2,i,j)
132  enddo
133  enddo
134 c
135  endif
136 c
137  if(kzz.eq.2)then
138  call crftout
139  ef=amuo*efactb(nolyr+1)
140  ftot=(gz+ef)
141  do i=1,(nx-1)
142  do j=1,jpart
143  cttdn(i,j)=(fiocrft(1,i,j)+fiocrft(2,i,j))
144  enddo
145  enddo
146  do i=nx,nmum1
147  m=(nmum1-i+1)
148  do j=1,jpart
149  cttup(m,j)=(fiocrft(1,i,j)+fiocrft(2,i,j))
150  enddo
151  enddo
152  do i=1,(nx-1)
153  do j=1,jpart
154  crfttup(ksza,i,j)=cttup(i,j)*ftot
155  crfttdn(ksza,i,j)=cttdn(i,j)*ftot
156  enddo
157  enddo
158  endif
159 c
160  if(nsza.gt.1)then
161  ef=amuo*efactb(nolyr+1)
162  ftot=(gz+ef)
163  do i=1,(nx-1)
164  do j=1,jpart
165  crfttup(ksza,i,j)=cttup(i,j)*ftot
166  crfttdn(ksza,i,j)=cttdn(i,j)*ftot
167  enddo
168  enddo
169  endif
170 c
171  return
172  end
173 c
174 c**********************************************************************
subroutine fluxlvl(buft, sumg, iflag)
Definition: fluxlvl.f:2
subroutine xntpln(x, x1, x2, y1, y2, y)
Definition: xntpln.f:2
subroutine crftgcr
Definition: crftgcr.f:2
#define pi
Definition: vincenty.c:23
subroutine crftout
Definition: crftout.f:2