OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
multp2d.f
Go to the documentation of this file.
1  subroutine multp2d
2 c
3 c compute the multiple scattering contribution when the atmosphere is
4 c illuminated from the bottom. 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 'afrt_rt2.cmn'
11 c
12 c**************************************************************************
13 c
14 c compute the downward diffuse radiation at each level
15 c
16  read(irad,rec=1)fiib
17  write(iwrt,rec=1)fiib
18  do il=1,nolyr
19  ilp=il+1
20  ilm=il-1
21  if(il.eq.1)then
22  read(iwrt,rec=il)fiib
23  read(irad,rec=ilp)fio
24 c determine average intensity at the center of the layer il
25  do i=1,nmum1
26  do j=1,jpart
27  do k=1,4
28  fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
29  ftmp(k,i,j)=0.0d0
30  enddo
31  enddo
32  enddo
33  tmsl=dtmm(il)*qsqt*const
34  trsl=dtrr(il)*conr
35  dlyr=dtot(il)
36  if(ifc.eq.0)tmsl=0.0d0
37  call mdiffn(1,nx-1,il,dlyr)
38  do i=1,nx-1
39  do j=1,jpart
40  do k=1,4
41  fio(k,i,j)=fiib(k,i,j)*emdtm(il,i)+
42  1 ftmp(k,i,j)*(1.0d0-emdtm(il,i))
43  enddo
44  enddo
45  enddo
46  write(iwrt,rec=ilp)fio
47  else
48  read(iwrt,rec=ilm)fiib
49  do i=1,nmum1
50  do j=1,jpart
51  do k=1,4
52  fiic(k,i,j)=fio(k,i,j)
53  ftmp(k,i,j)=0.0d0
54  enddo
55  enddo
56  enddo
57  read(irad,rec=ilp)fio
58  tmsl=(dtmm(ilm)+dtmm(il))*qsqt*const
59  trsl=(dtrr(ilm)+dtrr(il))*conr
60  dlyr=(dtot(ilm)+dtot(il))
61  if(ifc.eq.0)tmsl=0.0d0
62  call mdiffn(1,nx-1,il,dlyr)
63  do i=1,nx-1
64  do j=1,jpart
65  do k=1,4
66  fio(k,i,j)=fiib(k,i,j)*emdtm(ilm,i)*emdtm(il,i)+
67  1 ftmp(k,i,j)*(1.0d0-emdtm(ilm,i)*emdtm(il,i))
68  enddo
69  enddo
70  enddo
71  write(iwrt,rec=ilp)fio
72  endif
73  enddo
74 c
75 c if(iref.eq.1 .and. itrans.eq.1)then
76 c call fltocn_diff
77 c write(iwrt,rec=nolyr+1)fio
78 c endif
79 c
80 c compute the upward diffuse radiation at each level
81  do il=1,nolyr
82  im=nolyr-il+1
83  imp=im+1
84  impp=imp+1
85  if(il.eq.1)then
86  read(iwrt,rec=imp)fiib
87  read(iwrt,rec=im)fio
88  do i=1,nmum1
89  do j=1,jpart
90  do k=1,4
91  fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
92  ftmp(k,i,j)=0.0d0
93  enddo
94  enddo
95  enddo
96  tmsl=dtmm(im)*qsqt*const
97  trsl=dtrr(im)*conr
98  dlyr=dtot(im)
99  if(ifc.eq.0)tmsl=0.0d0
100  call mdiffn(nx,nmum1,im,dlyr)
101  do i=nx,nmum1
102  do j=1,jpart
103  do k=1,4
104  fio(k,i,j)=fiib(k,i,j)*emdtm(im,i)+
105  1 ftmp(k,i,j)*(1.0d0-emdtm(im,i))
106  enddo
107  enddo
108  enddo
109  write(iwrt,rec=im)fio
110  else
111  read(iwrt,rec=impp)fiib
112  do i=1,nmum1
113  do j=1,jpart
114  do k=1,4
115  fiic(k,i,j)=fio(k,i,j)
116  ftmp(k,i,j)=0.0d0
117  enddo
118  enddo
119  enddo
120  read(iwrt,rec=im)fio
121  tmsl=(dtmm(imp)+dtmm(im))*qsqt*const
122  trsl=(dtrr(imp)+dtrr(im))*conr
123  dlyr=(dtot(imp)+dtot(im))
124  if(ifc.eq.0)tmsl=0.0d0
125  call mdiffn(nx,nmum1,im,dlyr)
126  do i=nx,nmum1
127  do j=1,jpart
128  do k=1,4
129  fio(k,i,j)=fiib(k,i,j)*emdtm(imp,i)*emdtm(im,i)+
130  1 ftmp(k,i,j)*(1.0d0-emdtm(imp,i)*emdtm(im,i))
131  enddo
132  enddo
133  enddo
134  write(iwrt,rec=im)fio
135  endif
136  enddo
137 c
138  return
139  end
140 c***********************************************************************
subroutine const(NGAUSS, NMAX, MMAX, P, X, W, AN, ANN, S, SS, NP, EPS)
Definition: ampld.lp.f:924
subroutine multp2d
Definition: multp2d.f:2
subroutine mdiffn(ib, ie, il, dlyr)
Definition: mdiffn.f:2
Definition: RsViirs.h:71