OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
mats.f
Go to the documentation of this file.
1  subroutine mats(l)
2 c
3 c***********************************************************************
4 c include the common statements.....................................
5  implicit real*8 (a-h,o-z)
6  include 'common_all.cmn'
7 c***********************************************************************
8 c
9  x = amu * amup + anu * anup * coosn
10  xabs=dabs(x)
11  if(x.gt.1.0d0)x=1.0d0
12  if(x.lt.-1.0d0)x=-1.0d0
13  if(xabs .lt. 1.0e-6)x=0.0
14  xza=dacos(x)*57.29578d0
15 c write(6,213)kk,ii,l,amup,amu,anup,anu,coosn,x,xza
16 213 format('mats kk,ii,l,amup,amu,anup,anu,coosn,x'/3i3,7f7.3)
17  y=dasin(x)*57.29578d0
18  mtz=91.5-y
19  tf1=(dacos(x)/conv)
20  tf=10.0d0*tf1+1.0
21  tfm1=idint(tf+0.01d0)
22  tfp1=tfm1+1.0d0
23  if(l-jpart)16,16,17
24  17 mt=1
25  mn=nomat
26  go to 19
27  16 continue
28  mt=idint(tf+0.01d0)
29  18 mn=(l-1)*32
30  19 continue
31 c write(6,1253)mtz,y,mt,tf1,tf
32 1253 format('mtz,y,mt,tf1,tf',i3,1x,1pe11.3,1x,i3,1x,1p2e11.3)
33  call xntpln(tf,tfm1,tfp1,t(mt,1),t(mt+1,1),tmt1)
34  call xntpln(tf,tfm1,tfp1,t(mt,2),t(mt+1,2),tmt2)
35  call xntpln(tf,tfm1,tfp1,t(mt,3),t(mt+1,3),tmt3)
36  call xntpln(tf,tfm1,tfp1,t(mt,4),t(mt+1,4),tmt4)
37 c
38 c tmt1=t(mt,1)
39 c tmt2=t(mt,2)
40 c tmt3=t(mt,3)
41 c tmt4=t(mt,4)
42 c
43 c write(6,565)kk,ii,l,mt,xza,tf,tfm1,tfp1,t(mt,1),t(mt+1,1),tmt1
44 565 format('kk,ii,l,mt,xza,tf,tfm1,tfp1,tm1,tm+1,tmt1'/
45  1 3i3,i5,0p4f8.3,1p3e11.3)
46 c
47  p(1,l)=cfisq*tmt1+sisq*tmt2+2.0d0*sifi*tmt3
48  p(2,l)=sfisq*(amups*tmt1+amusq*tmt2+2.0d0*amumu*tmt3)
49  p(3,l)=siin*(amup*coosn*tmt1+amu*copsi*tmt2+(amup*copsi+
50  1amu*coosn)*tmt3)
51  p(4,l)=siin*(amu*coosn-amup*copsi)*tmt4
52  p(5,l)=sfisq*(amups*tmt2+amusq*tmt1+2.0d0*amumu*tmt3)
53  p(6,l)=sisq*tmt1+cfisq*tmt2+2.0d0*sifi*tmt3
54 c
55  pmats=const*0.5d0*(p(1,l)+p(2,l)+p(5,l)+p(6,l))*4.0d0*pi
56 c write(6,560)kk,ii,l,mt,xza,tf,tfm1,tfp1,tmt1,tmt2,pmats
57 560 format('kk,ii,l,mt,xza,tf,tfm1,tfp1,tmt1,tmt2,pmats'/
58  1 3i3,i5,0p4f8.3,1p3e11.3)
59 c
60  p(7,l)=-siin*(amup*coosn*tmt2+amu*copsi*tmt1+(amup*copsi+
61  1amu*coosn)*tmt3)
62  p(8,l)=-p(4,l)
63  p(9,l) = -2.0d0*siin*(amu*coosn*tmt1+amup*copsi*tmt2+
64  1 (amup*coosn+amu*copsi)*tmt3)
65  p(10,l) = 2.0d0*siin*(amu*coosn*tmt2+amup*copsi*tmt1+
66  1 (amup*coosn+amu*copsi)*tmt3)
67  p(11,l)=(sifi-amumu*sfisq)*(tmt1+tmt2)+(cfisq+sisq-sfisq
68  1*(amusq+amups))*tmt3
69  p(12,l)=(cfisq-sisq-sfisq*(amusq-amups))*tmt4
70  p(13,l) = -2.0d0*siin*(amu*copsi-amup*coosn)*tmt4
71  p(14,l)=-p(13,l)
72  p(15,l)=(sisq-cfisq-sfisq*(amusq-amups))*tmt4
73  p(16,l)=(sifi+amumu*sfisq)*(tmt1+tmt2)+(cfisq+sisq+sfisq
74  1*(amusq+amups))*tmt3
75  p(17,l)=sisq
76  p(18,l)=amusq*sfisq
77  p(19,l)=amu*copsi*siin
78  p(20,l)=0.0d0
79  p(21,l)=amups*sfisq
80  p(22,l)=cfisq
81  p(23,l)=-amup*coosn*siin
82  p(24,l)=0.0d0
83  p(25,l) = -2.0d0*amup*copsi*siin
84  p(26,l) = 2.0d0*amu*coosn*siin
85  p(27,l)=-amumu*sfisq+sifi
86  p(28,l)=0.0d0
87  p(29,l)=0.0d0
88  p(30,l)=0.0d0
89  p(31,l)=0.0d0
90  p(32,l)=amumu*sfisq+sifi
91 c apply molecular depolarization correction
92 c write(6,121)ipol,rho,gamma,agm,bgm,cgm
93 121 format('mtrx..ipol,rho,gamma,agm,bgm,cgm',i2,1x,1p5e11.3)
94  if(ipol.eq.1)then
95  do i=1,3
96  do j=1,3
97  k=16+(i-1)*4+j
98  dgm=bgm
99  if(i.eq.3 .or. j.eq.3)dgm=0.0d0
100  p(k,l)=agm*p(k,l)+dgm
101  enddo
102  enddo
103  p(32,l)=p(32,l)+cgm
104  endif
105 c
106 c write(6,*)'leaving mats'
107  return
108  end
109 c
110 c************************************************************************
subroutine const(NGAUSS, NMAX, MMAX, P, X, W, AN, ANN, S, SS, NP, EPS)
Definition: ampld.lp.f:924
subroutine xntpln(x, x1, x2, y1, y2, y)
Definition: xntpln.f:2
#define pi
Definition: vincenty.c:23
subroutine mats(l)
Definition: matrx.f:72