1 | include(dom.inc)
2 |
3 | SUBROUTINE DERI_KAPPA(ivar, delta, order, dkptot)
4 |
5 | USE mod_slave
6 | USE mod_inout
7 |
8 | IMPLICIT NONE
9 |
10 | include 'dom_constants.h'
11 |
12 | ! IN
13 | DOM_INT :: ivar, order
14 | DOM_REAL :: delta
15 |
16 | ! LOCAL
17 | DOM_INT :: iquad, idelta, i
18 | DOM_INT :: ngbands, ios
19 | DOM_REAL :: DWVNB_SI, planck
20 | DOM_REAL,DIMENSION(order,is_nkabs,is_nnodes) :: all_kabs, allWSGG
21 | DOM_REAL,DIMENSION(is_nkabs) :: wkabs
22 | DOM_REAL,DIMENSION(is_nnodes) :: Lb, dkptot, dkabs
23 | DOM_REAL,DIMENSION(8,is_nnodes) :: data
24 | DOM_REAL,DIMENSION(order) :: delta_data
25 | DOM_REAL,DIMENSION(is_ncells) :: dkabs_cell, Lb_cell
26 | DOM_REAL, ALLOCATABLE, DIMENSION(:,:) :: data_cell
27 |
28 | all_kabs = 0.
29 | data = s_celldata
30 | DO i=1, is_nnodes
31 | Lb(i) = planck(s_celldata(1,i))
32 | ENDDO
33 |
34 | IF(order.eq. 2) THEN
35 | delta_data(1) = -delta
36 | delta_data(2) = delta
37 | ENDIF
38 |
39 | DO idelta = 1, order
40 |
41 | data(ivar, :) = s_celldata(ivar,:) + delta_data(idelta)
42 |
43 | DWVNB_SI = 1.0
44 | ngbands = is_nallbandes
45 |
46 | ! ---------------------!
47 | ! WSGG case treatement !
48 | ! ---------------------!
49 | IF (mediumtype.eq.'WSGG') THEN
50 |
51 | wkabs = 1.0
52 |
53 | CALL WSGG_CASE(all_kabs(idelta,:,:),s_WSGG_W,Lb,data, &
54 | & is_nnodes, s_alpha,s_kwsgg,s_all_WVNB, &
55 | & s_all_DWVNB, is_ngg,is_nallbandes, 1, &
56 | & is_nnodes)
57 |
58 | ! --------------------!
59 | ! FSK CASE TREATEMENT !
60 | ! --------------------!
61 | ELSEIF (mediumtype.eq.'FSK') THEN
62 |
63 | s_WSGG_W = 1.0
64 |
65 | CALL FSK_CASE(all_kabs(idelta,:,:), wkabs, data,is_nnodes, &
66 | & s_all_WVNB, s_all_DWVNB, s_KCO, s_DCO, s_KC, &
67 | & s_DC, s_KH, s_DH, ngbands, is_nallbandes, &
68 | & is_nkabs, is_lbcd, is_lbcf)
69 |
70 | ! ---------------------!
71 | ! FSCK CASE TREATEMENT !
72 | ! ---------------------!
73 | ELSEIF (mediumtype.eq.'FSCK') THEN
74 |
75 | IF(.not.ALLOCATED(data_cell)) &
76 | & ALLOCATE(data_cell(8,is_ncells))
77 | CALL GATHER(s_celldata, data_cell, 8)
78 |
79 | ! -------------------------------!
80 | ! Choice of the reference state !
81 | ! 0 -> from input_fsck.dat !
82 | ! 1 -> average state !
83 | ! 2 -> Maximal temperature !
84 | ! 3 -> Maximal absorbing species !
85 | ! -------------------------------!
86 |
87 | IF (i_refstate.eq.0) THEN
88 | OPEN(UNIT=1,FILE='input_fsck.dat',FORM='FORMATTED', &
89 | & STATUS='old',IOSTAT=ios)
90 | DO i=1,8
91 | READ(1,*,IOSTAT=ios) s_dataref(i)
92 | ENDDO
93 | IF (ios.ne.0) THEN
94 | PRINT*, "Error reading input_fsck.dat"
95 | STOP
96 | ENDIF
97 |
98 | ELSEIF (i_refstate.eq.1) THEN
99 | CALL VOLAVERAGE(data_cell,s_dataref,8,1)
100 | DEALLOCATE(data_cell)
101 | ELSEIF (i_refstate.eq.2) THEN
102 | i = MAXVAL(MAXLOC(s_celldata(1,:)))
103 | s_dataref(:) = s_celldata(:,i)
104 | ELSEIF (i_refstate.eq.3) THEN
105 | i = MAXVAL(MAXLOC(s_celldata(3:5,:)))
106 | s_dataref(:) = s_celldata(:,i)
107 | ENDIF
108 |
109 | IF (.not.ALLOCATED(s_WSGG_Wb)) THEN
110 | ALLOCATE(s_WSGG_Wb(is_nkabs,is_nbfaces))
111 | ENDIF
112 |
113 | CALL FSCK_CASE(all_kabs(idelta,:,:), wkabs, data,is_nnodes, &
114 | & s_all_WVNB, s_all_DWVNB, s_KCO, s_DCO, s_KC, &
115 | & s_DC, s_KH, s_DH, ngbands, is_nallbandes, &
116 | & is_nkabs, s_dataref, s_WSGG_W, &
117 | & is_lbcd, is_lbcf, s_WSGG_Wb, s_Tf,is_nbfaces)
118 |
119 | ! ---------------------------------------!
120 | ! Tabulated FSCK and FSK CASE TREATEMENT !
121 | ! ---------------------------------------!
122 |
123 | ELSEIF ((mediumtype.eq.'TFSCK').or.(mediumtype.eq.'TFSK')) THEN
124 |
125 | IF(mediumtype.eq.'TFSCK') THEN
126 |
127 | IF (.not.ALLOCATED(s_WSGG_Wb)) THEN
128 | ALLOCATE(s_WSGG_Wb(is_nkabs,is_nbfaces))
129 | ENDIF
130 |
131 | CALL TFSCK_CASE(data ,is_nnodes, &
132 | & s_all_WVNB, s_all_DWVNB, s_KCO, s_DCO, s_KC, &
133 | & s_DC, s_KH, s_DH, ngbands, is_nallbandes, &
134 | & is_nkabs, s_dataref, s_WSGG_W, &
135 | & 1, is_nnodes, s_WSGG_Wb, s_Tf,is_nbfaces)
136 |
137 | ELSE
138 |
139 | s_WSGG_W = 1.0
140 |
141 | ENDIF
142 |
143 | CALL TFSK_CASE(data, all_kabs(idelta,:,:), wkabs, s_tabkabs,&
144 | & s_DYH, s_DYC, s_DYCO, is_nYH, is_nYC, is_nYCO,&
145 | & s_DT, is_nT, is_nkabs, &
146 | & is_nnodes, is_nallbandes, s_all_WVNB, &
147 | & s_all_DWVNB, 1, is_nnodes)
148 |
149 | ELSE
150 | PRINT*," Unknown spectral type to derive kappa",mediumtype
151 | ENDIF
152 |
153 | allWSGG(idelta,:,:) = s_WSGG_W(:,:)
154 |
155 | ENDDO
156 |
157 | dkptot = 0
158 |
159 | call gather(Lb, Lb_cell, 1)
160 | call scatter(Lb_cell, Lb,1)
161 |
162 | DO iquad = 1, is_nkabs
163 |
164 | IF(delta.eq.0.or.order.lt.2) THEN
165 | dkabs(:) = all_kabs(1,iquad,:)*allWSGG(1,iquad,:)
166 | ELSEIF (order.eq.2) THEN
167 | dkabs(:) = (all_kabs(2,iquad,:) &
168 | & - all_kabs(1,iquad,:))/delta
169 | ENDIF
170 |
171 | ! With Gather/scatter
172 | call gather(dkabs*(allWSGG(1,iquad,:)+allWSGG(2,iquad,:))/2, &
173 | & dkabs_cell,1)
174 | call scatter(dkabs_cell, dkabs, 1)
175 |
176 | dkptot(:) = dkptot(:) + Lb(:)*4*pi*dkabs(:)*wkabs(iquad) &
177 | & *DWVNB_SI
178 |
179 | ! Without Gather/Scatter
180 | ! dkptot(:) = dkptot(:) + Lb(:)*4*pi*dkabs(:)*wkabs(iquad) &
181 | ! & *DWVNB_SI*s_WSGG_W(iquad,:)
182 |
183 | ENDDO
184 |
185 | dkptot(:) = dkptot(:) / (4*pi*sigma*s_celldata(1,:)**4)
186 |
187 | ENDSUBROUTINE DERI_KAPPA
deri_kappa.F could be called by: