OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
multp1d.f
Go to the documentation of this file.
1  subroutine multp1d
2 c
3 c compute the multiple 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 c
12 c**************************************************************************
13 c
14 c compute the downward diffuse radiation at each level
15 c
16  isng=53
17  read(irad,rec=1)fiib
18  write(iwrt,rec=1)fiib
19  do il=1,nolyr
20  ilp=il+1
21  ilm=il-1
22  if(il.eq.1)then
23  read(iwrt,rec=il)fiib
24  read(irad,rec=ilp)fio
25  read(isng,rec=il)sngla
26  read(isng,rec=ilp)snglb
27 c determine average intensity at the center of the layer il
28  do i=1,nmum1
29  do j=1,jpart
30  do k=1,4
31  fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
32  ftmp(k,i,j)=0.0d0
33  enddo
34  enddo
35  enddo
36  tmsl=dtmm(il)*qsqt*const
37  trsl=dtrr(il)*conr
38  dlyr=dtot(il)
39  if(ifc.eq.0)tmsl=0.0d0
40  call mdiffn(1,jjjj,il,dlyr)
41  do i=1,jjjj
42  do j=1,jpart
43  do k=1,4
44  fio(k,i,j)=fiib(k,i,j)*emdtm(il,i)+
45  1 ftmp(k,i,j)*(1.0d0-emdtm(il,i))+
46  2 snglb(k,i,j)-sngla(k,i,j)*emdtm(il,i)
47  enddo
48  enddo
49  enddo
50  write(iwrt,rec=ilp)fio
51  else
52  read(iwrt,rec=ilm)fiib
53  read(isng,rec=ilm)sngla
54  read(isng,rec=ilp)snglb
55  do i=1,nmum1
56  do j=1,jpart
57  do k=1,4
58  fiic(k,i,j)=fio(k,i,j)
59  ftmp(k,i,j)=0.0d0
60  enddo
61  enddo
62  enddo
63  read(irad,rec=ilp)fio
64  tmsl=(dtmm(ilm)+dtmm(il))*qsqt*const
65  trsl=(dtrr(ilm)+dtrr(il))*conr
66  dlyr=(dtot(ilm)+dtot(il))
67  if(ifc.eq.0)tmsl=0.0d0
68  call mdiffn(1,jjjj,il,dlyr)
69  do i=1,jjjj
70  do j=1,jpart
71  do k=1,4
72  fio(k,i,j)=fiib(k,i,j)*emdtm(ilm,i)*emdtm(il,i)+
73  1 ftmp(k,i,j)*(1.0d0-emdtm(ilm,i)*emdtm(il,i))+
74  2 snglb(k,i,j)-sngla(k,i,j)*emdtm(ilm,i)*emdtm(il,i)
75  enddo
76  enddo
77  enddo
78  write(iwrt,rec=ilp)fio
79 c
80  endif
81  enddo
82 c
83  if(iref.eq.1)then
84  call fltocn_new
85  write(iwrt,rec=nolyrp)fio
86  endif
87 
88  if(iref.eq.2)then
89 c call rsea_new
90  if(iocn.eq.1) then
91  call rsea_new
92  else
93 c call RSEA
94  endif
95  write(iwrt,rec=nolyrp)fio
96  endif
97 c
98  if(iref.eq.3)then
99  call brdfg(fio,brdfx,bmu,dmu,dmus2,eo,ddphi,amuo,pi,sumc,
100  1 sumcpi,sumdwn,calb,kkx,jjjj,nmum1,jpart)
101  write(iwrt,rec=nolyrp)fio
102  endif
103 c
104 c compute the upward diffuse radiation at each level
105 c
106  do il=1,nolyr
107  im=nolyr-il+1
108  imp=im+1
109  impp=imp+1
110  if(il.eq.1)then
111  read(iwrt,rec=imp)fiib
112  read(iwrt,rec=im)fio
113  read(isng,rec=imp)sngla
114  read(isng,rec=im)snglb
115  do i=1,nmum1
116  do j=1,jpart
117  do k=1,4
118  fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
119  ftmp(k,i,j)=0.0d0
120  enddo
121  enddo
122  enddo
123  tmsl=dtmm(im)*qsqt*const
124  trsl=dtrr(im)*conr
125  dlyr=dtot(im)
126  if(ifc.eq.0)tmsl=0.0d0
127  call mdiffn(jjj,nmum1,im,dlyr)
128  do i=jjj,nmum1
129  do j=1,jpart
130  do k=1,4
131  fio(k,i,j)=fiib(k,i,j)*emdtm(im,i)+
132  1 ftmp(k,i,j)*(1.0d0-emdtm(im,i))+
133  2 snglb(k,i,j)-sngla(k,i,j)*emdtm(im,i)
134  enddo
135  enddo
136  enddo
137  write(iwrt,rec=im)fio
138  else
139  read(iwrt,rec=impp)fiib
140  read(isng,rec=impp)sngla
141  read(isng,rec=im)snglb
142  do i=1,nmum1
143  do j=1,jpart
144  do k=1,4
145  fiic(k,i,j)=fio(k,i,j)
146  ftmp(k,i,j)=0.0d0
147  enddo
148  enddo
149  enddo
150  read(iwrt,rec=im)fio
151  tmsl=(dtmm(imp)+dtmm(im))*qsqt*const
152  trsl=(dtrr(imp)+dtrr(im))*conr
153  dlyr=(dtot(imp)+dtot(im))
154  if(ifc.eq.0)tmsl=0.0d0
155  call mdiffn(jjj,nmum1,im,dlyr)
156  do i=jjj,nmum1
157  do j=1,jpart
158  do k=1,4
159  fio(k,i,j)=fiib(k,i,j)*emdtm(imp,i)*emdtm(im,i)+
160  1 ftmp(k,i,j)*(1.0d0-emdtm(imp,i)*emdtm(im,i))+
161  2 snglb(k,i,j)-sngla(k,i,j)*emdtm(imp,i)*emdtm(im,i)
162  enddo
163  enddo
164  enddo
165  write(iwrt,rec=im)fio
166 c
167  endif
168  enddo
169 c
170  return
171  end
172 c
173 c************************************************************************
subroutine brdfg(fio, brdfx, bmu, dmu, dmus2, eo, ddphi, amuo, pi, sumc, sumcpi, sumdwn, calb, kkx, nx, nmum1, jpart)
Definition: brdfg.f:3
subroutine fltocn_new
Definition: fltocn_new.f:2
subroutine const(NGAUSS, NMAX, MMAX, P, X, W, AN, ANN, S, SS, NP, EPS)
Definition: ampld.lp.f:924
subroutine mdiffn(ib, ie, il, dlyr)
Definition: mdiffn.f:2
subroutine multp1d
Definition: multp1d.f:2
subroutine rsea_new
Definition: rsea_new.f:2
#define pi
Definition: vincenty.c:23
Definition: RsViirs.h:71