OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
single.f
Go to the documentation of this file.
1  subroutine single
2 c
3 c compute the single scattering contribution when the atmosphere is
4 c illuminated from the top. also, for each level, store the
5 c upwelling/downwelling diffuse radiation.
6 c
7 c*************************************************************************
8 c.....includes the common blocks
9  implicit real*8 (a-h,o-z)
10  include 'common_all.cmn'
11  real*8 pfs(32,46,50)
12  equivalence(pfs(1,1,1),pc(1,1,1))
13 c
14 c**************************************************************************
15 c
16 c initialize the buffers
17 c
18  do i=1,4
19  do j=1,nmum1
20  do k=1,jpart
21  fio(i,j,k)=0.0d0
22  ftmp(i,j,k)=0.0d0
23  enddo
24  enddo
25  enddo
26 c
27 c initialize all levels
28 c
29  do il=1,nolyrp
30  write(53,rec=il)fio
31  write(64,rec=il)fio
32  enddo
33 c
34 c compute the downward diffuse radiation at each level
35 c
36  write(53,rec=1)fio
37 c
38  do il=1,nolyr
39  ilp=il+1
40  read(53,rec=il)fiib
41  read(53,rec=ilp)fio
42  tmsl=dtmm(il)*qsqt*const
43  trsl=dtrr(il)*conr
44 c
45  do is=1,4
46  qfi(is)=ei(is)*efact(il)/dtot(il)
47  enddo
48 c write(6,*)'layer no,qfi,efact,ei(1),dtot',il,qfi,efact(il),
49 c 1 ei(1),dtot(il)
50 c
51  do it=1,jjjj
52  do ip=1,jpart
53  do is=1,4
54  gfot(is)=0.0d0
55  enddo
56  do i=1,4
57  do j=1,4
58  ij=(i-1)*4+j
59  gfot(i)=gfot(i)+(pfs(ij,ip,it)*tmsl +
60  1 pfs(ij+16,ip,it)*trsl)*qfi(j)
61  enddo
62  ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(il,it))
63  if(i.gt.2)then
64  do ks=3,4
65  ftmp(ks,it,ip)=-ftmp(ks,it,ip)
66  enddo
67  endif
68  fio(i,it,ip)=fiib(i,it,ip)*emdtm(il,it)+
69  1 ftmp(i,it,ip)
70  enddo
71  enddo
72  enddo
73 c
74 c write(6,*)'Bottom of layer num ',il
75 c do i=1,jjjj
76 c call radnce(pi,conv,bmu,the,fio,i,jpart,jphi)
77 c enddo
78 
79  write(53,rec=ilp)fio
80  write(54,rec=il)ftmp
81 c
82  enddo
83 c
84 c write(6,*)'Single....Bottom....Downwelling'
85 c do i=1,jjjj
86 c call radnce(pi,conv,bmu,the,fio,i,jpart,jphi)
87 c enddo
88 c
89  if(iref.eq.1)then
90 c write(*,*)'Ready to call fltocn'
91 c write(*,*)'rmu',rmu
92  call fltocn_new
93 c call fltocn(fio,bmu,dmu,dmus2,eo,ddphi,amuo,pi,sumc,sumcpi,
94 c 1 sumdwn,calb,rmu,conv,eox,kkx,jjjj,nmum1,jpart)
95  write(53,rec=nolyrp)fio
96  endif
97 c
98 c write(6,*)'Single....Bottom....Upwelling...After Relection'
99 c do i=jjj,nmum1
100 c call radnce(pi,conv,bmu,the,fio,i,jpart,jphi)
101 c enddo
102 c
103 c save the reflected radiation
104  do i=jjj,nmum1
105  do j=1,jpart
106  do k=1,4
107  ftmpb(k,i,j)=fio(k,i,j)
108  enddo
109  enddo
110  enddo
111 c compute the upward diffuse radiation at each level
112 
113  do il=1,nolyr
114  im=nolyr-il+1
115  imp=im+1
116  read(53,rec=imp)fiib
117  read(53,rec=im)fio
118  read(54,rec=im)ftmp
119  tmsl=dtmm(im)*qsqt*const
120  trsl=dtrr(im)*conr
121 
122  do is=1,4
123  qfi(is)=ei(is)*efact(im)/dtot(im)
124  enddo
125 
126  do it=jjj,nmum1
127  do ip=1,jpart
128  do is=1,4
129  gfot(is)=0.0d0
130  enddo
131  do i=1,4
132  do j=1,4
133  ij=(i-1)*4+j
134  gfot(i)=gfot(i)+(pfs(ij,ip,it)*tmsl+
135  1 pfs(ij+16,ip,it)*trsl)*qfi(j)
136  enddo
137  ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(im,it))
138  if(i.gt.2)then
139  do ks=3,4
140  ftmp(ks,it,ip)=-ftmp(ks,it,ip)
141  enddo
142  endif
143  fio(i,it,ip)=fiib(i,it,ip)*emdtm(im,it)+ftmp(i,it,ip)
144  enddo
145  enddo
146  enddo
147 c
148 c add the contribution from the specular reflection
149 c do is=1,4
150 c qfi(is)=eox(is)*efact(il)/dtot(il)
151 c enddo
152 c
153 c do it=jjj,nmum1
154 c itp=nmum1-it+1
155 c do ip=1,jpart
156 c do is=1,4
157 c gfot(is)=0.0d0
158 c enddo
159 c do i=1,4
160 c do j=1,4
161 c ij=(i-1)*4+j
162 c gfot(i)=gfot(i)+(pfs(ij,ip,itp)*tmsl +
163 c 1 pfs(ij+16,ip,itp)*trsl)*qfi(j)
164 c enddo
165 c ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(im,itp))
166 c if(i.gt.2)then
167 c do ks=3,4
168 c ftmp(ks,it,ip)=-ftmp(ks,it,ip)
169 c enddo
170 c endif
171 c fio(i,it,ip)=fio(i,it,ip)+ftmp(i,it,ip)+
172 c 1 ftmpb(i,it,ip)*atnflx(il+1,it)
173 c enddo
174 c enddo
175 c enddo
176 c
177 c
178  write(53,rec=im)fio
179  write(54,rec=im)ftmp
180 c
181  enddo
182 c copy all records to unit 64 for multiple scattering calculations
183 c
184  do il=1,nolyrp
185  read(53,rec=il)ftmp
186  write(64,rec=il)ftmp
187  enddo
188 c
189 c write(6,*)'Single....Top....Upwelling'
190  do i=jjj,nmum1
191 c call radnce(pi,conv,bmu,the,fio,i,jpart,jphi)
192  enddo
193 c
194 
195  return
196  end
197 c***********************************************************************
subroutine fltocn_new
Definition: fltocn_new.f:2
#define real
Definition: DbAlgOcean.cpp:26
subroutine const(NGAUSS, NMAX, MMAX, P, X, W, AN, ANN, S, SS, NP, EPS)
Definition: ampld.lp.f:924
float ei(float x)
subroutine single
Definition: single.f:2
Definition: RsViirs.h:71