1 | include(dom.inc)
2 |
3 | SUBROUTINE slave
4 |
5 | ! ================================================================!
6 | ! !
7 | ! slave.F : Main control of the slave side of the code. !
8 | ! !
9 | ! out : !
10 | ! !
11 | ! author : J. AMAYA (september 2007) !
12 | ! !
13 | ! ================================================================!
14 |
15 | #ifdef USEPALM
16 | USE palm_prissma
17 | USE palmlib
18 | #endif
19 |
20 | USE mod_inout
21 | USE mod_pmm
22 | USE mod_slave
23 |
24 | IMPLICIT NONE
25 |
26 | include 'pmm_constants.h'
27 |
28 | ! LOCAL
29 | #ifdef USEPALM
30 | DOM_INT :: i_iter
31 | #endif
32 | DOM_INT :: ib_beg, ib_end, finprog, i, ierr, j, ibnd
33 | DOM_INT :: is_dirbeg, is_dirend, i_bande, ngbands
34 | DOM_INT :: ICO,ICO2,IH2O
35 | LOGICAL :: LICO,LICO2,LIH2O
36 | DOM_REAL :: DWVNB_SI, WVNB_SI
37 | DOM_REAL :: DWVNB, WVNB
38 |
39 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: wkabs
40 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: Lb, Lo, Lb_cell
41 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: kscat_cell
42 | DOM_REAL, ALLOCATABLE, DIMENSION(:,:) :: all_k_abs, kabs_cell
43 | DOM_REAL, ALLOCATABLE, DIMENSION(:,:) :: data_cell
44 |
45 | DOM_REAL, ALLOCATABLE, DIMENSION(:,:) :: Q_rtot
46 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: Gtot, Lbtot, Htot
47 |
48 | DOM_REAL, ALLOCATABLE, DIMENSION(:,:) :: Q_rtot_n
49 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: Gtot_n, Lbtot_n,Qw
50 |
51 | ! Speed-up debugging variables
52 | DOM_DBLE :: cic_beg_time, cic_end_time
53 | DOM_DBLE :: lum_beg_time, lum_end_time
54 | DOM_DBLE :: snb_beg_time, snb_end_time
55 | DOM_DBLE :: bint_beg_time, bint_end_time
56 |
57 | DOM_DBLE :: cic_mean_time
58 | DOM_DBLE :: lum_mean_time
59 | DOM_DBLE :: snb_mean_time
60 | DOM_DBLE :: bint_mean_time
61 |
62 | ! Tabulation variables
63 | CHARACTER*64 :: tabfile
64 | DOM_INT :: nYH, nYC, nYCO, nT
65 | DOM_REAL :: DYH, DYC, DYCO, DT
66 | DOM_REAL :: MH2O, MCO2, MCO
67 | DOM_REAL, ALLOCATABLE,DIMENSION(:,:,:,:,:) :: tabkabs
68 |
69 | ! --------------------------------------!
70 | ! Receive vectors from master processor !
71 | ! --------------------------------------!
72 |
73 | IF (pmm_rank.ne.PMM_HOST) THEN
74 | CALL slave_receive
75 | ENDIF
76 |
77 | ! ------------------------!
78 | ! Load runing parammeters !
79 | ! ------------------------!
80 |
81 | CALL read_data_slave
82 |
83 | ! -----------------------------!
84 | ! Read data for tabulated FSCK !
85 | ! -----------------------------!
86 |
87 | IF (mediumtype.eq.'TAB') THEN
88 | tabfile = pathspec(1:len_trim(pathspec))//'/table.dat'
89 | PRINT*, "Tabulated File : ",tabfile
90 |
91 | OPEN(12,FILE=tabfile,FORM='FORMATTED')
92 | READ(12,*) is_nkabs
93 | READ(12,*) DT
94 | READ(12,*) DYH, MH2O
95 | READ(12,*) DYC, MCO2
96 | READ(12,*) DYCO, MCO
97 | CLOSE(12)
98 |
99 | nT = INT((2900-300)/DT) + 1
100 | nYH = INT((MH2O-0.0)/DYH) + 1
101 | nYC = INT((MCO2-0.0)/DYC) + 1
102 | nYCO = INT((MCO-0.0)/DYCO) + 1
103 |
104 | ALLOCATE(tabkabs(nYH,nYC,nYCO,nT,is_nkabs))
105 |
106 | CALL readtab(tabfile,tabkabs,nYH,nYC,nYCO,nT,is_nkabs)
107 | PRINT*, "Table for FS-SNBcK model readed"
108 |
109 | ELSEIF (mediumtype.eq.'GRAY') THEN
110 | is_nkabs = 1
111 | ELSEIF (mediumtype.eq.'WSGG') THEN
112 | is_nkabs = is_ngg
113 | ELSE
114 | is_nkabs = Nq_kabs
115 | ENDIF
116 |
117 | ! -----------------!
118 | ! Allocate vectors !
119 | ! -----------------!
120 |
121 | IF (.not.ALLOCATED(wkabs)) ALLOCATE(wkabs(is_nkabs))
122 | IF (.not.ALLOCATED(Lo)) ALLOCATE(Lo(is_nbfaces))
123 | IF (.not.ALLOCATED(Q_rtot)) ALLOCATE(Q_rtot(3,is_ncells))
124 | IF (.not.ALLOCATED(Gtot)) ALLOCATE(Gtot(is_ncells))
125 | IF (.not.ALLOCATED(Lbtot)) ALLOCATE(Lbtot(is_ncells))
126 | IF (.not.ALLOCATED(Htot)) ALLOCATE(Htot(is_nbfaces))
127 |
128 | #ifdef USEPALM
129 | ! -------------------------!
130 | ! PALM: Main coupling loop !
131 | ! -------------------------!
132 |
133 | DO i_iter = 1, i_dom_iterations
134 |
135 | WRITE(*,*) " (PRISSMA ",pmm_rank,") Coupling it:",i_iter,"/", &
136 | & i_dom_iterations
137 |
138 | ! -------------------------------!
139 | ! Receive fluid fields from PALM !
140 | ! -------------------------------!
141 |
142 | ! print*, " (PRISSMA ",pmm_rank,") Waiting for fluid fields"
143 | CALL interf_recvfields
144 | ! print*, " (PRISSMA ",pmm_rank,") Fluid data received"
145 | #endif
146 |
147 | ! --------------------------!
148 | ! Initialize result vectors !
149 | ! --------------------------!
150 |
151 | Gtot = 0.
152 | Lbtot = 0.
153 | Htot = 0.
154 | Q_rtot = 0.
155 |
156 | finprog = 0
157 |
158 | ! ------------------------!
159 | ! Initialize time counter !
160 | ! ------------------------!
161 |
162 | #ifdef USEPALM
163 | ! CALL MPI_BARRIER(PL_COMM_EXEC ,ierr)
164 | #else
165 | CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
166 | #endif
167 | ! CALL cpu_time(sc_time)
168 | sc_time = MPI_WTIME()
169 |
170 | ! -----------------------!
171 | ! Global spectral models !
172 | ! -----------------------!
173 | IF (mediumtype.ne.'SNB-CK') THEN
174 |
175 | cic_mean_time = 0
176 | lum_mean_time = 0
177 | snb_mean_time = 0
178 |
179 | CALL cpu_time(cic_beg_time)
180 |
181 | DWVNB_SI = 1.0
182 | ngbands = is_nallbandes
183 |
184 | IF(.not.ALLOCATED(Lb)) ALLOCATE(Lb(is_nnodes))
185 |
186 | CALL cpu_time(lum_beg_time)
187 | CALL EMISSIV(s_celldata, Lb, Lo, s_epsil, s_Tf, &
188 | & is_nnodes, is_lbcd, is_lbcf, &
189 | & is_bcell, is_bface, is_nbfaces, is_bfbeg, &
190 | & is_bfend)
191 | CALL cpu_time(lum_end_time)
192 | lum_mean_time=lum_mean_time+(lum_end_time-lum_beg_time)
193 |
194 | IF(.not.ALLOCATED(all_k_abs)) &
195 | & ALLOCATE(all_k_abs(is_nkabs,is_nnodes))
196 |
197 | ! -------------------!
198 | ! GRAY gas tratement !
199 | ! -------------------!
200 | IF (mediumtype.eq.'GRAY') THEN
201 |
202 | WRITE(*,*) " (",pmm_rank,") Gray case calculation"
203 |
204 | wkabs = 1.0
205 | all_k_abs(1,:) = s_kabs_gray(:)
206 |
207 | ! ---------------------!
208 | ! WSGG case treatement !
209 | ! ---------------------!
210 | ELSEIF (mediumtype.eq.'WSGG') THEN
211 |
212 | wkabs = 1.0
213 | IF (.not.ALLOCATED(s_WSGG_W)) THEN
214 | ALLOCATE(s_WSGG_W(is_ngg,is_nnodes))
215 | ENDIF
216 |
217 | WRITE(*,*) " (",pmm_rank,") WSGG case calculation"
218 |
219 | CALL cpu_time(snb_beg_time)
220 | CALL WSGG_CASE(all_k_abs,s_WSGG_W,Lb,s_celldata,is_nnodes, &
221 | & s_alpha,s_kwsgg,s_all_WVNB,s_all_DWVNB, &
222 | & is_ngg,is_nallbandes,is_lbcd,is_lbcf)
223 | CALL cpu_time(snb_end_time)
224 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
225 |
226 | ! -------------------------!
227 | ! SNB-FSCK CASE TREATEMENT !
228 | ! -------------------------!
229 |
230 | ELSEIF ((mediumtype.eq.'FSCK').or.(mediumtype.eq.'TAB')) THEN
231 |
232 | IF (mediumtype.eq.'FSCK') THEN
233 |
234 | WRITE(*,*) " (",pmm_rank,") FSCK case calculation"
235 |
236 | CALL cpu_time(snb_beg_time)
237 | CALL FSCK_CASE(all_k_abs, wkabs, Lb, s_celldata,is_nnodes,&
238 | & s_all_WVNB, s_all_DWVNB, s_KCO, s_DCO, s_KC, &
239 | & s_DC, s_KH, s_DH, ngbands, is_nallbandes, &
240 | & is_nkabs, is_lbcd, is_lbcf)
241 | CALL cpu_time(snb_end_time)
242 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
243 |
244 | ELSEIF (mediumtype.eq.'TAB') THEN
245 |
246 | WRITE(*,*) " (",pmm_rank,") FSCK TAB case calculation"
247 |
248 | CALL cpu_time(snb_beg_time)
249 | CALL TAB_CASE(s_celldata, all_k_abs, wkabs, tabkabs, DYH, &
250 | & DYC, DYCO, nYH, nYC, nYCO, DT, nT, is_nkabs, &
251 | & is_nnodes, is_nallbandes, s_all_WVNB, &
252 | & s_all_DWVNB, Lb, is_lbcd, is_lbcf)
253 | CALL cpu_time(snb_end_time)
254 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
255 |
256 | ENDIF
257 |
258 | ELSE
259 | WRITE(*,*) " Fatal error: unknown spectral type ",mediumtype
260 | finprog=1
261 | ENDIF
262 |
263 | ! ---------------!
264 | ! Gather vectors !
265 | ! ---------------!
266 |
267 | IF(.not.ALLOCATED(kabs_cell)) &
268 | & ALLOCATE(kabs_cell(is_nkabs,is_ncells))
269 | IF(.not.ALLOCATED(kscat_cell)) ALLOCATE(kscat_cell(is_ncells))
270 | IF(.not.ALLOCATED(Lb_cell)) ALLOCATE(Lb_cell(is_ncells))
271 |
272 | CALL GATHER(all_k_abs, kabs_cell, is_nkabs)
273 | CALL GATHER(s_k_scat, kscat_cell, 1)
274 | CALL GATHER(Lb, Lb_cell, 1)
275 |
276 | #ifndef USEPALM
277 | IF (ALLOCATED(s_celldata)) DEALLOCATE(s_celldata)
278 | IF (ALLOCATED(all_k_abs)) DEALLOCATE(all_k_abs)
279 | IF (ALLOCATED(s_k_scat)) DEALLOCATE(s_k_scat)
280 | IF (ALLOCATED(Lb)) DEALLOCATE(Lb)
281 | #endif
282 |
283 |
284 | ! ----------------------------!
285 | ! Integrate over the spectrum !
286 | ! ----------------------------!
287 |
288 | is_dirbeg = 1
289 | is_dirend = is_ndir
290 |
291 | bint_mean_time = 0
292 | CALL cpu_time(bint_beg_time)
293 |
294 | WRITE(*,*) " (",pmm_rank,") ",is_nkabs,"points integration"
295 |
296 | CALL BAND_INTEG(wkabs, kabs_cell, kscat_cell, Lb_cell, Lo, &
297 | & WVNB_SI, DWVNB_SI, &
298 | & Gtot, Lbtot, Htot, Q_rtot)
299 |
300 | CALL cpu_time(bint_end_time)
301 | bint_mean_time=bint_end_time-bint_beg_time
302 |
303 | CALL cpu_time(cic_end_time)
304 | cic_mean_time = cic_mean_time + (cic_end_time-cic_beg_time)
305 |
306 | ! -----------------------!
307 | ! SNB-CK case treatement !
308 | ! -----------------------!
309 |
310 | ELSEIF (mediumtype.eq.'SNB-CK') THEN
311 |
312 | ! ---------------!
313 | ! Gather vectors !
314 | ! ---------------!
315 |
316 | IF(.not.ALLOCATED(data_cell)) ALLOCATE(data_cell(8,is_ncells))
317 | IF(.not.ALLOCATED(Lb)) ALLOCATE(Lb(is_ncells))
318 | IF(.not.ALLOCATED(kscat_cell)) ALLOCATE(kscat_cell(is_ncells))
319 | IF(.not.ALLOCATED(all_k_abs)) &
320 | & ALLOCATE(all_k_abs(is_nkabs,is_ncells))
321 |
322 | CALL GATHER(s_celldata, data_cell, 8)
323 | CALL GATHER(s_k_scat, kscat_cell, 1)
324 |
325 | #ifndef USEPALM
326 | IF (ALLOCATED(s_celldata)) DEALLOCATE(s_celldata)
327 | IF (ALLOCATED(s_k_scat)) DEALLOCATE(s_k_scat)
328 | #endif
329 |
330 | cic_mean_time = 0
331 | lum_mean_time = 0
332 | snb_mean_time = 0
333 | bint_mean_time = 0
334 |
335 | WRITE(*,*) " (",pmm_rank,") SNB-CK case calculation"
336 |
337 | ! ----------------------------!
338 | ! Calculate spectral interval !
339 | ! ----------------------------!
340 |
341 | ib_beg = 1
342 | ib_end = is_nallbandes
343 | ! IF (is_ndir.eq.1) THEN
344 | ! ib_beg = is_cd
345 | ! ib_end = is_cf
346 | ! ENDIF
347 |
348 | ! --------------------!
349 | ! Loop over all bands !
350 | ! --------------------!
351 |
352 | ! print*, " (",pmm_rank,") ibeg-iend:", ib_beg, ib_end
353 | DO i_bande = ib_beg, ib_end
354 |
355 | CALL cpu_time(cic_beg_time)
356 |
357 | ! ------------------!
358 | ! Set partitionning !
359 | ! ------------------!
360 |
361 | is_dirbeg = 2
362 | IF (i_bande.ge.is_cd) is_dirbeg = 1
363 |
364 | is_dirend = is_ndir - 1
365 | IF (i_bande.le.is_cf) is_dirend = is_ndir
366 |
367 | ! print*, " (",pmm_rank,") d_beg, d_end:",is_dirbeg,is_dirend
368 |
369 | ! -----------!
370 | ! Initialize !
371 | ! -----------!
372 |
373 | WVNB = s_all_WVNB(i_bande)
374 | DWVNB = s_all_DWVNB(i_bande)
375 | WVNB_SI = 100.*WVNB
376 | DWVNB_SI = 100.*DWVNB
377 |
378 | ngbands = 1
379 |
380 | CALL cpu_time(lum_beg_time)
381 | CALL EMISSIV_SNB(data_cell, Lb, Lo, s_epsil, &
382 | & s_Tf, WVNB_SI, is_ncells, &
383 | & is_cellb, is_cellf, is_bcell, is_bface, &
384 | & is_nbfaces,is_bfbeg,is_bfend)
385 | CALL cpu_time(lum_end_time)
386 | lum_mean_time=lum_mean_time+(lum_end_time-lum_beg_time)
387 |
388 | CALL cpu_time(snb_beg_time)
389 |
390 | CALL SNB_CASE(all_k_abs, wkabs, Lb, data_cell, is_ncells, &
391 | & s_all_WVNB, s_all_DWVNB, s_KCO, s_DCO, s_KC, &
392 | & s_DC, s_KH, s_DH, ngbands, i_bande, &
393 | & is_nallbandes, is_nkabs, is_cellb, is_cellf)
394 |
395 | CALL cpu_time(snb_end_time)
396 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
397 |
398 | ! ------------------------!
399 | ! Integrate over the band !
400 | ! ------------------------!
401 |
402 | CALL cpu_time(bint_beg_time)
403 |
404 | IF (pmm_rank.eq.PMM_HOST) THEN
405 | WRITE(*,*) " Band: ", i_bande,"/", ib_end
406 | ENDIF
407 |
408 | CALL BAND_INTEG(wkabs, all_k_abs, kscat_cell, Lb, Lo, &
409 | & WVNB_SI, DWVNB_SI, &
410 | & Gtot, Lbtot, Htot, Q_rtot)
411 | CALL cpu_time(bint_end_time)
412 | bint_mean_time=bint_mean_time+(bint_end_time-bint_beg_time)
413 |
414 |
415 | ! --------------------!
416 | ! Testing the results !
417 | ! --------------------!
418 | ! IF (i_bande.eq.1) THEN
419 | ! DO i=1,is_nnodes
420 | ! print*, "Lb(",i,")=",Lbtot(i)
421 | ! ENDDO
422 | ! ENDIF
423 |
424 | CALL cpu_time(cic_end_time)
425 | cic_mean_time = cic_mean_time + (cic_end_time-cic_beg_time)
426 |
427 | ! WRITE(69,*) i_bande, (cic_end_time-cic_beg_time)
428 |
429 | ENDDO
430 |
431 | ! ---------------------------------------------------!
432 | ! Stop computation time counter and reduce to master !
433 | ! ---------------------------------------------------!
434 |
435 | ec_time = MPI_WTIME()
436 | ! CALL cpu_time(ec_time)
437 | #ifdef USEPALM
438 | CALL MPI_REDUCE(ec_time-sc_time,c_time,1,MPI_DOUBLE_PRECISION,&
439 | & MPI_MAX, PMM_HOST, PL_COMM_EXEC , ierr)
440 | #else
441 | CALL MPI_REDUCE(ec_time-sc_time,c_time,1,MPI_DOUBLE_PRECISION,&
442 | & MPI_MAX, PMM_HOST, MPI_COMM_WORLD, ierr)
443 | #endif
444 |
445 | cic_mean_time=cic_mean_time/(ib_end-ib_beg)
446 | bint_mean_time=bint_mean_time/(ib_end-ib_beg)
447 | snb_mean_time=snb_mean_time/(ib_end-ib_beg)
448 | lum_mean_time=lum_mean_time/(ib_end-ib_beg)
449 |
450 | ENDIF
451 |
452 | IF (pmm_rank.eq.0) THEN
453 | print*, " Mean time per band :",cic_mean_time,"sec."
454 | print*, " + Planck luminance:",lum_mean_time,"sec."
455 | print*, " + Kabs model :",snb_mean_time,"sec."
456 | print*, " + Band integration:",bint_mean_time,"sec."
457 | ENDIF
458 |
459 | ! ---------------------------!
460 | ! Send results to the master !
461 | ! ---------------------------!
462 |
463 | IF (finprog .ne. 1) THEN
464 |
465 | ! ----------------!
466 | ! Scatter results !
467 | ! ----------------!
468 |
469 | IF (.not.ALLOCATED(Gtot_n)) ALLOCATE(Gtot_n(is_nnodes))
470 | IF (.not.ALLOCATED(Lbtot_n)) ALLOCATE(Lbtot_n(is_nnodes))
471 | IF (.not.ALLOCATED(Q_rtot_n)) ALLOCATE(Q_rtot_n(3,is_nnodes))
472 | IF (.not.ALLOCATED(Qw)) ALLOCATE(Qw(is_nbfaces))
473 |
474 | CALL SCATTER(Gtot, Gtot_n, 1)
475 | CALL SCATTER(Lbtot, Lbtot_n, 1)
476 | CALL SCATTER(Q_rtot, Q_rtot_n, 3)
477 |
478 |
479 | DO ibnd = 1,is_nbfaces
480 |
481 | j = is_bcell(ibnd)
482 | i = is_bface(ibnd)
483 | Qw(ibnd) = Q_rtot(1,j)*s_norm(1,i,j) + &
484 | & Q_rtot(2,j)*s_norm(2,i,j) + &
485 | & Q_rtot(3,j)*s_norm(3,i,j)
486 |
487 |
488 | ENDDO
489 |
490 | #ifndef USEPALM
491 | DEALLOCATE(Gtot)
492 | DEALLOCATE(Lbtot)
493 | DEALLOCATE(Q_rtot)
494 | #endif
495 |
496 | WRITE(*,*) " (",pmm_rank,") Send results to the master"
497 | CALL slave_return(Gtot_n, Lbtot_n, Htot, Q_rtot_n, Qw, &
498 | & is_nnodes, is_nbfaces)
499 |
500 | IF (pmm_rank.eq.PMM_HOST) THEN
501 | CALL master_control(MASTER_OUTPROC)
502 | ENDIF
503 |
504 | ENDIF
505 |
506 | #ifdef USEPALM
507 | ! ---------------------------------------!
508 | ! PALM: End of the coupling loop (ENDDO) !
509 | ! ---------------------------------------!
510 | ! print*, " DOM (",pmm_rank,") END OF COUPLING ITERATION"
511 | ENDDO
512 | #endif
513 |
514 | END SUBROUTINE slave
slave.F could be called by: