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 & D. Poitou (september 2007) !
12 | ! !
13 | ! ================================================================!
14 |
15 | #ifdef USEPALM
16 | USE palm_prissma
17 | USE palmlib
18 | USE palm_user_param
19 | #endif
20 |
21 | USE mod_inout
22 | USE mod_pmm
23 | USE mod_slave
24 | !$ USE OMP_LIB
25 |
26 | IMPLICIT NONE
27 |
28 | include 'pmm_constants.h'
29 |
30 | ! LOCAL
31 | #ifdef USEPALM
32 | DOM_INT :: i_iter
33 | #endif
34 | DOM_INT :: ib_beg, ib_end, finprog, i, ierr
35 | DOM_INT :: i_bande, ifreq, ngbands, ios
36 | DOM_INT :: n_iter, ntot_iter
37 | DOM_REAL :: DWVNB, WVNB, DWVNB_SI, WVNB_SI
38 | DOM_STR80 :: filefsck
39 |
40 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: wkabs, Lb, Lo
41 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: Lb_cell, 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, Q_ptot
46 | DOM_REAL, ALLOCATABLE, DIMENSION(:) :: Gtot, Lbtot, Htot
47 |
48 | ! Speed-up debugging variables
49 | DOM_DBLE :: cic_beg_time, cic_end_time, cic_mean_time
50 | DOM_DBLE :: lum_beg_time, lum_end_time, lum_mean_time
51 | DOM_DBLE :: snb_beg_time, snb_end_time, snb_mean_time
52 | DOM_DBLE :: bint_beg_time, bint_end_time, bint_mean_time
53 |
54 | ! ------------------------------------------!
55 | ! OpenMP parallel calculation on directions !
56 | ! ------------------------------------------!
57 | !$ CALL OMP_SET_NUM_THREADS(i_dom_nthread)
58 |
59 | ! --------------------------------------!
60 | ! Receive vectors from master processor !
61 | ! --------------------------------------!
62 |
63 | IF (pmm_rank.ne.PMM_HOST) THEN
64 | CALL slave_receive
65 | ENDIF
66 |
67 | IF(i_dom_npart.gt.1) THEN
68 | CALL MPI_COMM_SPLIT(COMM_PARA, is_part, is_task, SUB_COMM, ierr)
69 | ELSE
70 | SUB_COMM = COMM_PARA
71 | ENDIF
72 |
73 | ! ------------------------!
74 | ! Load runing parammeters !
75 | ! ------------------------!
76 |
77 | CALL read_data_slave
78 |
79 | ! ---------------------------------------------!
80 | ! Initialize boundary faces between subdomains !
81 | ! -> coupling: the values from the previous !
82 | ! iteration is the initial guess.
83 | ! ---------------------------------------------!
84 | IF(ALLOCATED(s_Lvirt)) DEALLOCATE(s_Lvirt)
85 |
86 | IF(mediumtype.ne.'CK') THEN
87 | ALLOCATE(s_Lvirt(is_ntot_vfaces,is_ntotdir,is_nkabs, 1))
88 | ELSE
89 | ALLOCATE(s_Lvirt(is_ntot_vfaces,is_ntotdir,is_nkabs, &
90 | & is_nallbandes))
91 | ENDIF
92 | s_Lvirt = 0
93 |
94 | ! ---------------------------------------!
95 | ! Allocate and Initialize result vectors !
96 | ! ---------------------------------------!
97 |
98 | IF (.not.ALLOCATED(wkabs)) ALLOCATE(wkabs(is_nkabs))
99 | IF (.not.ALLOCATED(Lo)) ALLOCATE(Lo(is_nbfaces))
100 |
101 | IF (.not.ALLOCATED(Lbtot)) ALLOCATE(Lbtot(is_ncells))
102 | IF (.not.ALLOCATED(Gtot)) ALLOCATE(Gtot(is_ncells))
103 | IF (.not.ALLOCATED(Htot)) ALLOCATE(Htot(is_nbfaces))
104 | IF (.not.ALLOCATED(Q_rtot)) ALLOCATE(Q_rtot(3,is_ncells))
105 | IF (.not.ALLOCATED(Q_ptot)) ALLOCATE(Q_ptot(3,is_nprobes))
106 |
107 | Lbtot = 0.
108 | Gtot = 0.
109 | Htot = 0.
110 | Q_rtot = 0.
111 | Q_ptot = 0.
112 |
113 | #ifdef USEPALM
114 | ! -------------------------!
115 | ! PALM: Main coupling loop !
116 | ! -------------------------!
117 |
118 | DO i_iter = 1, i_dom_iterations
119 |
120 | IF (pmm_rank.eq.PMM_HOST) THEN
121 | WRITE(*,*) " (PRISSMA) Coupling it:",i_iter,"/", &
122 | & i_dom_iterations
123 | ENDIF
124 |
125 | ! -------------------------------!
126 | ! Receive fluid fields from PALM !
127 | ! -------------------------------!
128 |
129 | ! print*, " (PRISSMA ",pmm_rank,") Waiting for fluid fields"
130 | CALL interf_recvfields
131 | ! print*, " (PRISSMA ",pmm_rank,") Fluid data received"
132 | #endif
133 |
134 | finprog = 0
135 |
136 | ! ------------------------!
137 | ! Initialize time counter !
138 | ! ------------------------!
139 |
140 | #ifdef USEPALM
141 | ! CALL MPI_BARRIER(COMM_PARA ,ierr)
142 | #else
143 | CALL MPI_BARRIER(COMM_PARA,ierr)
144 | #endif
145 | ! CALL cpu_time(sc_time)
146 | sc_time = MPI_WTIME()
147 |
148 | IF (pmm_rank.eq.PMM_HOST) THEN
149 | PRINT*
150 | IF(mediumtype.eq.'GRAY') THEN
151 | WRITE(*,*) " ->> Spectral model : Gray gas"
152 | ELSEIF(mediumtype.eq.'WSGG') THEN
153 | WRITE(*,*) " ->> Spectral model : WSGG"
154 | ELSE
155 | WRITE(*,*) " ->> Spectral model : ", &
156 | & trim(nb_base), "-", trim(mediumtype)
157 | ENDIF
158 | PRINT*
159 | ENDIF
160 |
161 | ! -----------------------!
162 | ! Global spectral models !
163 | ! -----------------------!
164 | IF (mediumtype.ne.'CK') THEN
165 |
166 | cic_mean_time = 0
167 | lum_mean_time = 0
168 | snb_mean_time = 0
169 |
170 | CALL cpu_time(cic_beg_time)
171 |
172 | DWVNB_SI = 1.0
173 | ngbands = is_nallbandes
174 |
175 | IF(.not.ALLOCATED(Lb)) ALLOCATE(Lb(is_nnodes))
176 | IF (.not.ALLOCATED(s_WSGG_W)) THEN
177 | ALLOCATE(s_WSGG_W(is_nkabs,is_nnodes))
178 | ENDIF
179 |
180 | CALL cpu_time(lum_beg_time)
181 | CALL EMISSIV(s_celldata, Lb, Lo, ts_boundary%epsil, &
182 | & ts_boundary%Tf, is_nnodes, 1, is_nnodes, &
183 | & is_nbfaces, 1, is_nbfaces)
184 | CALL cpu_time(lum_end_time)
185 | lum_mean_time=lum_mean_time+(lum_end_time-lum_beg_time)
186 |
187 | IF(.not.ALLOCATED(all_k_abs)) &
188 | & ALLOCATE(all_k_abs(is_nkabs,is_nnodes))
189 |
190 | ! -------------------!
191 | ! GRAY gas tratement !
192 | ! -------------------!
193 | IF (mediumtype.eq.'GRAY') THEN
194 |
195 | wkabs = 1.0
196 | s_WSGG_W = 1.0
197 | all_k_abs(1,:) = s_kabs_gray(:)
198 |
199 | ! ---------------------!
200 | ! WSGG case treatement !
201 | ! ---------------------!
202 | ELSEIF (mediumtype.eq.'WSGG') THEN
203 |
204 | wkabs = 1.0
205 |
206 | CALL cpu_time(snb_beg_time)
207 | CALL WSGG_CASE(all_k_abs,s_WSGG_W,Lb,s_celldata,is_nnodes, &
208 | & s_alpha,s_kwsgg,s_all_WVNB,s_all_DWVNB, &
209 | & is_ngg,is_nallbandes, is_lbcd, is_lbcf)
210 | CALL cpu_time(snb_end_time)
211 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
212 |
213 | ! --------------------!
214 | ! FSK CASE TREATEMENT !
215 | ! --------------------!
216 |
217 | ELSEIF (mediumtype.eq.'FSK') THEN
218 |
219 | s_WSGG_W = 1.0
220 |
221 | CALL cpu_time(snb_beg_time)
222 | CALL FSK_CASE(all_k_abs, wkabs, s_celldata,is_nnodes, &
223 | & s_all_WVNB, s_all_DWVNB, ngbands, &
224 | & is_nallbandes, is_nkabs, is_lbcd, is_lbcf)
225 | CALL cpu_time(snb_end_time)
226 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
227 |
228 | ! ---------------------!
229 | ! FSCK CASE TREATEMENT !
230 | ! ---------------------!
231 |
232 | ELSEIF (mediumtype.eq.'FSCK') THEN
233 |
234 | ! -------------------------------!
235 | ! Choice of the reference state !
236 | ! 0 -> from input_fsck.dat !
237 | ! 1 -> average state !
238 | ! 2 -> Maximal temperature !
239 | ! 3 -> Maximal absorbing species !
240 | ! -------------------------------!
241 |
242 | IF (i_refstate.eq.0) THEN
243 | IF (pmm_rank.eq.PMM_HOST) THEN
244 | PRINT*, "Read reference state from file input_fsck.dat"
245 | ENDIF
246 |
247 | #ifdef USEPALM
248 | filefsck = trim(rundomdir)//'input_fsck.dat'
249 | #else
250 | filefsck = 'input_fsck.dat'
251 | #endif
252 | OPEN(UNIT=1,FILE=filefsck,FORM='FORMATTED',STATUS='old', &
253 | & IOSTAT=ios)
254 |
255 | DO i=1,8
256 | READ(1,*,IOSTAT=ios) s_dataref(i)
257 | ENDDO
258 | IF (ios.ne.0) THEN
259 | PRINT*, "Error reading input_fsck.dat"
260 | STOP
261 | ENDIF
262 |
263 | ELSEIF (i_refstate.eq.1) THEN
264 | CALL VOLAVERAGE(s_celldata,s_dataref,8,1)
265 | ELSEIF (i_refstate.eq.2) THEN
266 | i = MAXVAL(MAXLOC(s_celldata(1,:)))
267 | s_dataref(:) = s_celldata(:,i)
268 | ELSEIF (i_refstate.eq.3) THEN
269 | i = MAXVAL(MAXLOC(s_celldata(3:5,:)))
270 | s_dataref(:) = s_celldata(:,i)
271 | ENDIF
272 |
273 | IF (.not.ALLOCATED(s_WSGG_Wb)) THEN
274 | ALLOCATE(s_WSGG_Wb(is_nkabs,is_nbfaces))
275 | ENDIF
276 |
277 | CALL cpu_time(snb_beg_time)
278 | CALL FSCK_CASE(all_k_abs, wkabs, s_celldata,is_nnodes, &
279 | & s_all_WVNB, s_all_DWVNB, ngbands, &
280 | & is_nallbandes, is_nkabs, s_dataref, s_WSGG_W,&
281 | & is_lbcd, is_lbcf, s_WSGG_Wb, ts_boundary%Tf, &
282 | & is_nbfaces)
283 | CALL cpu_time(snb_end_time)
284 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
285 |
286 | ! ---------------------------------------!
287 | ! Tabulated FSCK and FSK CASE TREATEMENT !
288 | ! ---------------------------------------!
289 |
290 | ELSEIF ((mediumtype.eq.'TFSCK').or.(mediumtype.eq.'TFSK')) THEN
291 |
292 | CALL cpu_time(snb_beg_time)
293 |
294 | IF(mediumtype.eq.'TFSCK') THEN
295 |
296 | IF (.not.ALLOCATED(s_WSGG_Wb)) THEN
297 | ALLOCATE(s_WSGG_Wb(is_nkabs,is_nbfaces))
298 | ENDIF
299 |
300 | CALL TFSCK_CASE(s_celldata,is_nnodes, &
301 | & s_all_WVNB, s_all_DWVNB, ngbands, &
302 | & is_nallbandes, is_nkabs, s_dataref, s_WSGG_W,&
303 | & is_lbcd, is_lbcf, s_WSGG_Wb, ts_boundary%Tf, &
304 | & is_nbfaces)
305 |
306 | ELSE
307 |
308 | s_WSGG_W = 1.0
309 |
310 | ENDIF
311 |
312 | CALL TFSK_CASE(s_celldata, all_k_abs, wkabs, s_tabkabs, &
313 | & s_DYH, s_DYC, s_DYCO, is_nYH, is_nYC, is_nYCO,&
314 | & s_DT, is_nT, is_nkabs, &
315 | & is_nnodes, is_nallbandes, s_all_WVNB, &
316 | & s_all_DWVNB, is_lbcd, is_lbcf)
317 |
318 | CALL cpu_time(snb_end_time)
319 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
320 |
321 | ELSE
322 | finprog = 1
323 | WRITE(*,*) " Fatal error: unknown spectral type ",mediumtype
324 | STOP
325 | ENDIF
326 |
327 | ! ---------------!
328 | ! Gather vectors !
329 | ! ---------------!
330 |
331 | IF(.not.ALLOCATED(kabs_cell)) &
332 | & ALLOCATE(kabs_cell(is_nkabs,is_ncells))
333 | IF(.not.ALLOCATED(kscat_cell)) ALLOCATE(kscat_cell(is_ncells))
334 | IF(.not.ALLOCATED(Lb_cell)) ALLOCATE(Lb_cell(is_ncells))
335 |
336 | CALL GATHER(all_k_abs, kabs_cell, is_nkabs)
337 | CALL GATHER(s_k_scat, kscat_cell, 1)
338 | CALL GATHER(Lb, Lb_cell, 1)
339 |
340 | #ifndef USEPALM
341 | ! IF (ALLOCATED(s_celldata)) DEALLOCATE(s_celldata)
342 | IF (ALLOCATED(all_k_abs)) DEALLOCATE(all_k_abs)
343 | IF (ALLOCATED(s_k_scat)) DEALLOCATE(s_k_scat)
344 | IF (ALLOCATED(Lb)) DEALLOCATE(Lb)
345 | #endif
346 |
347 | ! ----------------------------!
348 | ! Integrate over the spectrum !
349 | ! ----------------------------!
350 |
351 | bint_mean_time = 0
352 | CALL cpu_time(bint_beg_time)
353 |
354 | IF (finprog .ne. 1) THEN
355 |
356 | IF (pmm_rank.eq.PMM_HOST) THEN
357 | PRINT*, " ->> Spectral integration over ",is_nkabs,"points"
358 | ENDIF
359 |
360 | CALL BAND_INTEG(wkabs, kabs_cell, kscat_cell, Lb_cell, Lo, &
361 | & DWVNB_SI, Gtot, Lbtot, Htot, Q_rtot, Q_ptot)
362 | ENDIF
363 |
364 | CALL cpu_time(bint_end_time)
365 | bint_mean_time=bint_end_time-bint_beg_time
366 |
367 | CALL cpu_time(cic_end_time)
368 | cic_mean_time = cic_mean_time + (cic_end_time-cic_beg_time)
369 |
370 | ! -------------------!
371 | ! CK case treatement !
372 | ! -------------------!
373 |
374 | ELSEIF (mediumtype.eq.'CK') THEN
375 |
376 | IF (pmm_rank.eq.PMM_HOST) THEN
377 | PRINT*, " ->> Spectral integration over narrow bands: "
378 | ENDIF
379 |
380 | ! ---------------!
381 | ! Gather vectors !
382 | ! ---------------!
383 |
384 | IF(.not.ALLOCATED(data_cell)) ALLOCATE(data_cell(8,is_ncells))
385 | IF(.not.ALLOCATED(Lb)) ALLOCATE(Lb(is_ncells))
386 | IF(.not.ALLOCATED(kscat_cell)) ALLOCATE(kscat_cell(is_ncells))
387 | IF(.not.ALLOCATED(all_k_abs)) &
388 | & ALLOCATE(all_k_abs(is_nkabs,is_ncells))
389 |
390 | CALL GATHER(s_celldata, data_cell, 8)
391 | CALL GATHER(s_k_scat, kscat_cell, 1)
392 |
393 | #ifndef USEPALM
394 | IF (ALLOCATED(s_celldata)) DEALLOCATE(s_celldata)
395 | IF (ALLOCATED(s_k_scat)) DEALLOCATE(s_k_scat)
396 | #endif
397 |
398 | cic_mean_time = 0
399 | lum_mean_time = 0
400 | snb_mean_time = 0
401 | bint_mean_time = 0
402 | ntot_iter = 0
403 |
404 | ! ----------------------------!
405 | ! Calculate spectral interval !
406 | ! ----------------------------!
407 |
408 | ib_beg = 1
409 | ib_end = is_nallbandes
410 | ! IF (is_ndir.eq.1) THEN
411 | ! ib_beg = is_cd
412 | ! ib_end = is_cf
413 | ! ENDIF
414 |
415 | ! --------------------!
416 | ! Loop over all bands !
417 | ! --------------------!
418 |
419 | ! print*, " (",pmm_rank,") ibeg-iend:", ib_beg, ib_end
420 | DO i_bande = ib_beg, ib_end
421 |
422 | ifreq = ib_beg + i_bande -1
423 | CALL cpu_time(cic_beg_time)
424 |
425 | ! ------------------!
426 | ! Set partitionning !
427 | ! ------------------!
428 |
429 | is_dirbeg = 2
430 | IF (i_bande.ge.is_cd) is_dirbeg = 1
431 |
432 | is_dirend = is_ndir - 1
433 | IF (i_bande.le.is_cf) is_dirend = is_ndir
434 |
435 | ! print*, " (",pmm_rank,") d_beg, d_end:",is_dirbeg,is_dirend
436 |
437 | ! -----------!
438 | ! Initialize !
439 | ! -----------!
440 |
441 | WVNB = s_all_WVNB(i_bande)
442 | DWVNB = s_all_DWVNB(i_bande)
443 | WVNB_SI = 100.*WVNB
444 | DWVNB_SI = 100.*DWVNB
445 |
446 | ngbands = 1
447 |
448 | CALL cpu_time(lum_beg_time)
449 | CALL EMISSIV_SNB(data_cell, Lb, Lo, ts_boundary%epsil, &
450 | & ts_boundary%Tf, WVNB_SI, is_ncells, &
451 | & 1, is_ncells, is_nbfaces,1, is_nbfaces)
452 | CALL cpu_time(lum_end_time)
453 | lum_mean_time=lum_mean_time+(lum_end_time-lum_beg_time)
454 |
455 | CALL cpu_time(snb_beg_time)
456 |
457 | CALL CK_CASE(all_k_abs, wkabs, data_cell, is_ncells, &
458 | & s_all_WVNB, s_all_DWVNB, ngbands, i_bande, &
459 | & is_nallbandes, is_nkabs, is_cellb, is_cellf)
460 |
461 | CALL cpu_time(snb_end_time)
462 | snb_mean_time=snb_mean_time+(snb_end_time-snb_beg_time)
463 |
464 | ! ------------------------!
465 | ! Integrate over the band !
466 | ! ------------------------!
467 |
468 | CALL cpu_time(bint_beg_time)
469 |
470 | IF (pmm_rank.eq.PMM_HOST) THEN
471 | PRINT*, " + Band: ", i_bande,"/", ib_end
472 | ENDIF
473 |
474 | CALL BAND_INTEG_SNB(wkabs, all_k_abs, kscat_cell, Lb, Lo, &
475 | & DWVNB_SI, Gtot, Lbtot, Htot, Q_rtot, Q_ptot,&
476 | & ifreq, n_iter)
477 |
478 | IF(n_iter.ne.is_nkabs) ntot_iter = ntot_iter + n_iter
479 |
480 | CALL cpu_time(bint_end_time)
481 | bint_mean_time=bint_mean_time+(bint_end_time-bint_beg_time)
482 |
483 | CALL cpu_time(cic_end_time)
484 | cic_mean_time = cic_mean_time + (cic_end_time-cic_beg_time)
485 |
486 | ! WRITE(69,*) i_bande, (cic_end_time-cic_beg_time)
487 |
488 | ENDDO
489 |
490 | ! ---------------------------------------------------!
491 | ! Stop computation time counter and reduce to master !
492 | ! ---------------------------------------------------!
493 |
494 | ec_time = MPI_WTIME()
495 | ! CALL cpu_time(ec_time)
496 | IF((pmm_rank.eq.PMM_HOST).and.(ntot_iter.gt.0)) &
497 | & PRINT*, " >> Total subiterations over bands:", ntot_iter
498 |
499 | CALL MPI_REDUCE(ec_time-sc_time,c_time,1,MPI_DOUBLE_PRECISION,&
500 | & MPI_MAX, PMM_HOST, COMM_PARA , ierr)
501 |
502 | cic_mean_time = cic_mean_time /(ib_end-ib_beg)
503 | bint_mean_time = bint_mean_time/(ib_end-ib_beg)
504 | snb_mean_time = snb_mean_time /(ib_end-ib_beg)
505 | lum_mean_time = lum_mean_time /(ib_end-ib_beg)
506 |
507 | ENDIF
508 |
509 | !$ cic_mean_time = cic_mean_time / i_dom_nthread
510 | !$ bint_mean_time = bint_mean_time/ i_dom_nthread
511 | !$ snb_mean_time = snb_mean_time / i_dom_nthread
512 | !$ lum_mean_time = lum_mean_time / i_dom_nthread
513 |
514 | IF (pmm_rank.eq.PMM_HOST.and.finprog .ne. 1 ) THEN
515 | print*, " Mean time per band :",cic_mean_time,"sec."
516 | print*, " + Planck luminance:",lum_mean_time,"sec."
517 | print*, " + Kabs model :",snb_mean_time,"sec."
518 | print*, " + Band integration:",bint_mean_time,"sec."
519 | print*
520 | ENDIF
521 |
522 | ! ---------------------------!
523 | ! Send results to the master !
524 | ! ---------------------------!
525 |
526 | IF (finprog .ne. 1.) THEN
527 |
528 | IF(pmm_rank.eq.PMM_HOST) PRINT*," -> Postprocessing result &
529 | & vectors"
530 | CALL POSTPROCESSING(Lbtot, Gtot, Q_rtot, Q_ptot, Htot)
531 |
532 | IF (pmm_rank.eq.PMM_HOST) THEN
533 |
534 | WRITE(*,*) " >> MASTER: Receiving result vectors"
535 | WRITE(*,*)
536 |
537 | CALL master_integrate
538 | CALL master_control(MASTER_OUTPROC)
539 | ENDIF
540 |
541 | ENDIF
542 |
543 | #ifdef USEPALM
544 | ! ---------------------------------------!
545 | ! PALM: End of the coupling loop (ENDDO) !
546 | ! ---------------------------------------!
547 | ! print*, " DOM (",pmm_rank,") END OF COUPLING ITERATION"
548 | ENDDO
549 | #endif
550 | DEALLOCATE(s_Lvirt)
551 | IF(i_dom_npart.gt.1) CALL MPI_COMM_FREE(SUB_COMM,ierr)
552 |
553 | END SUBROUTINE slave
slave.F could be called by: