source: palm/trunk/SOURCE/pmc_parent_mod.f90 @ 1938

Last change on this file since 1938 was 1938, checked in by hellstea, 8 years ago

dependency errors corrected in Makefile

  • Property svn:keywords set to Id
File size: 30.4 KB
Line 
1 MODULE pmc_parent
2
3!-------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2016 Leibniz Universitaet Hannover
18!-------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22! Minor clean up.
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_parent_mod.f90 1938 2016-06-13 15:26:05Z hellstea $
27!
28! 1901 2016-05-04 15:39:38Z raasch
29! Module renamed. Code clean up. The words server/client changed to parent/child.
30!
31! 1900 2016-05-04 15:27:53Z raasch
32! re-formatted to match PALM style
33!
34! 1850 2016-04-08 13:29:27Z maronga
35! Module renamed
36!
37!
38! 1833 2016-04-07 14:23:03Z raasch
39! gfortran requires pointer attributes for some array declarations,
40! long line wrapped
41!
42! 1808 2016-04-05 19:44:00Z raasch
43! MPI module used by default on all machines
44!
45! 1797 2016-03-21 16:50:28Z raasch
46! introduction of different datatransfer modes
47!
48! 1791 2016-03-11 10:41:25Z raasch
49! Debug write-statements commented out
50!
51! 1786 2016-03-08 05:49:27Z raasch
52! change in child-parent data transfer: parent now gets data from child
53! instead that child put's it to the parent
54!
55! 1779 2016-03-03 08:01:28Z raasch
56! kind=dp replaced by wp,
57! error messages removed or changed to PALM style, dim_order removed
58! array management changed from linked list to sequential loop
59!
60! 1766 2016-02-29 08:37:15Z raasch
61! modifications to allow for using PALM's pointer version
62! +new routine pmc_s_set_active_data_array
63!
64! 1764 2016-02-28 12:45:19Z raasch
65! cpp-statement added (nesting can only be used in parallel mode)
66!
67! 1762 2016-02-25 12:31:13Z hellstea
68! Initial revision by K. Ketelsen
69!
70! Description:
71! ------------
72!
73! Parent part of Palm Model Coupler
74!-------------------------------------------------------------------------------!
75
76#if defined( __parallel )
77    USE, INTRINSIC ::  ISO_C_BINDING
78
79#if defined( __mpifh )
80    INCLUDE "mpif.h"
81#else
82    USE MPI
83#endif
84    USE kinds
85    USE pmc_general,                                                            &
86        ONLY: arraydef, childdef, da_namedef, da_namelen, pedef,                &
87              pmc_g_setname, pmc_max_array, pmc_max_models, pmc_sort
88
89    USE pmc_handle_communicator,                                                &
90        ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_child_comm,          &
91              m_world_rank, pmc_parent_for_child
92
93    USE pmc_mpi_wrapper,                                                        &
94        ONLY: pmc_alloc_mem, pmc_bcast, pmc_time
95
96   IMPLICIT NONE
97
98   PRIVATE
99   SAVE
100
101   TYPE childindexdef
102      INTEGER                              ::  nrpoints       !<
103      INTEGER, DIMENSION(:,:), ALLOCATABLE ::  index_list_2d  !<
104   END TYPE childindexdef
105
106   TYPE(childdef), DIMENSION(pmc_max_models)       ::  children     !<
107   TYPE(childindexdef), DIMENSION(pmc_max_models)  ::  indchildren  !<
108
109   INTEGER ::  next_array_in_list = 0  !<
110
111
112   PUBLIC pmc_parent_for_child
113
114
115   INTERFACE pmc_parentinit
116      MODULE PROCEDURE  pmc_parentinit
117   END INTERFACE pmc_parentinit
118
119    INTERFACE pmc_s_set_2d_index_list
120        MODULE PROCEDURE pmc_s_set_2d_index_list
121    END INTERFACE pmc_s_set_2d_index_list
122
123    INTERFACE pmc_s_clear_next_array_list
124        MODULE PROCEDURE pmc_s_clear_next_array_list
125    END INTERFACE pmc_s_clear_next_array_list
126
127    INTERFACE pmc_s_getnextarray
128        MODULE PROCEDURE pmc_s_getnextarray
129    END INTERFACE pmc_s_getnextarray
130
131    INTERFACE pmc_s_set_dataarray
132        MODULE PROCEDURE pmc_s_set_dataarray_2d
133        MODULE PROCEDURE pmc_s_set_dataarray_3d
134    END INTERFACE pmc_s_set_dataarray
135
136    INTERFACE pmc_s_setind_and_allocmem
137        MODULE PROCEDURE pmc_s_setind_and_allocmem
138    END INTERFACE pmc_s_setind_and_allocmem
139
140    INTERFACE pmc_s_fillbuffer
141        MODULE PROCEDURE pmc_s_fillbuffer
142    END INTERFACE pmc_s_fillbuffer
143
144    INTERFACE pmc_s_getdata_from_buffer
145        MODULE PROCEDURE pmc_s_getdata_from_buffer
146    END INTERFACE pmc_s_getdata_from_buffer
147
148    INTERFACE pmc_s_set_active_data_array
149        MODULE PROCEDURE pmc_s_set_active_data_array
150    END INTERFACE pmc_s_set_active_data_array
151
152    PUBLIC pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,       &
153           pmc_s_getdata_from_buffer, pmc_s_getnextarray,                       &
154           pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,              &
155           pmc_s_set_dataarray, pmc_s_set_2d_index_list
156
157 CONTAINS
158
159
160 SUBROUTINE pmc_parentinit
161
162    IMPLICIT NONE
163
164    INTEGER ::  childid   !<
165    INTEGER ::  i         !<
166    INTEGER ::  j         !<
167    INTEGER ::  istat     !<
168
169
170    DO  i = 1, SIZE( pmc_parent_for_child )-1
171
172       childid = pmc_parent_for_child( i )
173
174       children(childid)%model_comm = m_model_comm
175       children(childid)%inter_comm = m_to_child_comm(childid)
176
177!
178!--    Get rank and size
179       CALL MPI_COMM_RANK( children(childid)%model_comm,                        &
180                           children(childid)%model_rank, istat )
181       CALL MPI_COMM_SIZE( children(childid)%model_comm,                        &
182                           children(childid)%model_npes, istat )
183       CALL MPI_COMM_REMOTE_SIZE( children(childid)%inter_comm,                 &
184                                  children(childid)%inter_npes, istat )
185
186!
187!--    Intra communicater is used for MPI_GET
188       CALL MPI_INTERCOMM_MERGE( children(childid)%inter_comm, .FALSE.,         &
189                                 children(childid)%intra_comm, istat )
190       CALL MPI_COMM_RANK( children(childid)%intra_comm,                        &
191                           children(childid)%intra_rank, istat )
192
193       ALLOCATE( children(childid)%pes(children(childid)%inter_npes))
194
195!
196!--    Allocate array of TYPE arraydef for all child PEs to store information
197!--    of the transfer array
198       DO  j = 1, children(childid)%inter_npes
199         ALLOCATE( children(childid)%pes(j)%array_list(pmc_max_array) )
200       ENDDO
201
202       CALL get_da_names_from_child (childid)
203
204    ENDDO
205
206 END SUBROUTINE pmc_parentinit
207
208
209
210 SUBROUTINE pmc_s_set_2d_index_list( childid, index_list )
211
212     IMPLICIT NONE
213
214     INTEGER, INTENT(IN)                    :: childid     !<
215     INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list  !<
216
217     INTEGER ::  ian    !<
218     INTEGER ::  ic     !<
219     INTEGER ::  ie     !<
220     INTEGER ::  ip     !<
221     INTEGER ::  is     !<
222     INTEGER ::  istat  !<
223     INTEGER ::  n      !<
224
225
226     IF ( m_model_rank == 0 )  THEN
227
228!
229!--     Sort to ascending parent PE order
230        CALL pmc_sort( index_list, 6 )
231
232        is = 1
233        DO  ip = 0, m_model_npes-1
234
235!
236!--        Split into parent PEs
237           ie = is - 1
238
239!
240!--        There may be no entry for this PE
241           IF ( is <= SIZE( index_list,2 )  .AND.  ie >= 0 )  THEN
242
243              DO WHILE ( index_list(6,ie+1 ) == ip )
244                 ie = ie + 1
245                 IF ( ie == SIZE( index_list,2 ) )  EXIT
246              ENDDO
247
248              ian = ie - is + 1
249
250           ELSE
251              is  = -1
252              ie  = -2
253              ian =  0
254           ENDIF
255
256!
257!--        Send data to other parent PEs
258           IF ( ip == 0 )  THEN
259              indchildren(childid)%nrpoints = ian
260              IF ( ian > 0)  THEN
261                  ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
262                  indchildren(childid)%index_list_2d(:,1:ian) =                 &
263                                                             index_list(:,is:ie)
264              ENDIF
265           ELSE
266              CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,       &
267                             istat )
268              IF ( ian > 0)  THEN
269                  CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,      &
270                                 1001, m_model_comm, istat )
271              ENDIF
272           ENDIF
273           is = ie + 1
274
275        ENDDO
276
277     ELSE
278
279        CALL MPI_RECV( indchildren(childid)%nrpoints, 1, MPI_INTEGER, 0, 1000,  &
280                       m_model_comm, MPI_STATUS_IGNORE, istat )
281        ian = indchildren(childid)%nrpoints
282
283        IF ( ian > 0 )  THEN
284           ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
285           CALL MPI_RECV( indchildren(childid)%index_list_2d, 6*ian,            &
286                          MPI_INTEGER, 0, 1001, m_model_comm,                   &
287                          MPI_STATUS_IGNORE, istat)
288        ENDIF
289
290     ENDIF
291
292     CALL set_pe_index_list( childid, children(childid),                        &
293                             indchildren(childid)%index_list_2d,                &
294                             indchildren(childid)%nrpoints )
295
296 END SUBROUTINE pmc_s_set_2d_index_list
297
298
299
300 SUBROUTINE pmc_s_clear_next_array_list
301
302    IMPLICIT NONE
303
304    next_array_in_list = 0
305
306 END SUBROUTINE pmc_s_clear_next_array_list
307
308
309
310 LOGICAL FUNCTION pmc_s_getnextarray( childid, myname )
311
312!
313!-- List handling is still required to get minimal interaction with
314!-- pmc_interface
315!-- TODO: what does "still" mean? Is there a chance to change this!
316    CHARACTER(LEN=*), INTENT(OUT) ::  myname    !<
317    INTEGER(iwp), INTENT(IN)      ::  childid   !<
318
319    TYPE(arraydef), POINTER :: ar
320    TYPE(pedef), POINTER    :: ape
321
322    next_array_in_list = next_array_in_list + 1
323
324!
325!-- Array names are the same on all children PEs, so take first PE to get the name
326    ape => children(childid)%pes(1)
327
328    IF ( next_array_in_list > ape%nr_arrays )  THEN
329
330!
331!--    All arrays are done
332       pmc_s_getnextarray = .FALSE.
333       RETURN
334    ENDIF
335
336    ar => ape%array_list(next_array_in_list)
337    myname = ar%name
338
339!
340!-- Return true if legal array
341!-- TODO: what does this comment mean? Can there be non-legal arrays??
342    pmc_s_getnextarray = .TRUE.
343
344 END FUNCTION pmc_s_getnextarray
345
346
347
348 SUBROUTINE pmc_s_set_dataarray_2d( childid, array, array_2 )
349
350    IMPLICIT NONE
351
352    INTEGER,INTENT(IN) ::  childid   !<
353
354    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array    !<
355    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2  !<
356
357    INTEGER               ::  nrdims      !<
358    INTEGER, DIMENSION(4) ::  dims        !<
359    TYPE(C_PTR)           ::  array_adr   !<
360    TYPE(C_PTR)           ::  second_adr  !<
361
362
363    dims      = 1
364    nrdims    = 2
365    dims(1)   = SIZE( array,1 )
366    dims(2)   = SIZE( array,2 )
367    array_adr = C_LOC( array )
368
369    IF ( PRESENT( array_2 ) )  THEN
370       second_adr = C_LOC(array_2)
371       CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                   &
372                            second_adr = second_adr)
373    ELSE
374       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
375    ENDIF
376
377 END SUBROUTINE pmc_s_set_dataarray_2d
378
379
380
381 SUBROUTINE pmc_s_set_dataarray_3d( childid, array, nz_cl, nz, array_2 )
382
383    IMPLICIT NONE
384
385    INTEGER, INTENT(IN) ::  childid   !<
386    INTEGER, INTENT(IN) ::  nz        !<
387    INTEGER, INTENT(IN) ::  nz_cl     !<
388
389    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER           ::  array    !<
390    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2  !<
391
392    INTEGER               ::  nrdims      !<
393    INTEGER, DIMENSION(4) ::  dims        !<
394    TYPE(C_PTR)           ::  array_adr   !<
395    TYPE(C_PTR)           ::  second_adr  !<
396
397!
398!-- TODO: the next assignment seems to be obsolete. Please check!
399    dims      = 1
400    dims      = 0
401    nrdims    = 3
402    dims(1)   = SIZE( array,1 )
403    dims(2)   = SIZE( array,2 )
404    dims(3)   = SIZE( array,3 )
405    dims(4)   = nz_cl+dims(1)-nz  ! works for first dimension 1:nz and 0:nz+1
406
407    array_adr = C_LOC(array)
408
409!
410!-- In PALM's pointer version, two indices have to be stored internally.
411!-- The active address of the data array is set in swap_timelevel.
412    IF ( PRESENT( array_2 ) )  THEN
413      second_adr = C_LOC( array_2 )
414      CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                    &
415                           second_adr = second_adr)
416    ELSE
417       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
418    ENDIF
419
420 END SUBROUTINE pmc_s_set_dataarray_3d
421
422
423
424 SUBROUTINE pmc_s_setind_and_allocmem( childid )
425
426    USE control_parameters,                                                     &
427        ONLY:  message_string
428
429    IMPLICIT NONE
430
431!
432!-- Naming convention for appendices:   _pc  -> parent to child transfer
433!--                                     _cp  -> child to parent transfer
434!--                                     send -> parent to child transfer
435!--                                     recv -> child to parent transfer
436    INTEGER, INTENT(IN) ::  childid   !<
437
438    INTEGER                        ::  arlen    !<
439    INTEGER                        ::  i        !<
440    INTEGER                        ::  ierr     !<
441    INTEGER                        ::  istat    !<
442    INTEGER                        ::  j        !<
443    INTEGER                        ::  myindex  !<
444    INTEGER                        ::  rcount   !< count MPI requests
445    INTEGER                        ::  tag      !<
446
447    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
448    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
449
450    INTEGER, DIMENSION(1024)       ::  req      !<
451
452    TYPE(C_PTR)             ::  base_ptr  !<
453    TYPE(pedef), POINTER    ::  ape       !<
454    TYPE(arraydef), POINTER ::  ar        !<
455
456    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array for parent to child transfer
457    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array for child to parent transfer
458
459!
460!-- Parent to child direction
461    myindex = 1
462    rcount  = 0
463    bufsize = 8
464
465!
466!-- First stride: compute size and set index
467    DO  i = 1, children(childid)%inter_npes
468
469       ape => children(childid)%pes(i)
470       tag = 200
471
472       DO  j = 1, ape%nr_arrays
473
474          ar  => ape%array_list(j)
475          IF ( ar%nrdims == 2 )  THEN
476             arlen = ape%nrele
477          ELSEIF ( ar%nrdims == 3 )  THEN
478             arlen = ape%nrele * ar%a_dim(4)
479          ELSE
480             arlen = -1
481          ENDIF
482          ar%sendindex = myindex
483
484          tag    = tag + 1
485          rcount = rcount + 1
486          CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                    &
487                          children(childid)%inter_comm, req(rcount), ierr )
488
489!
490!--       Maximum of 1024 outstanding requests
491!--       TODO: what does this limit mean?
492          IF ( rcount == 1024 )  THEN
493             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
494             rcount = 0
495          ENDIF
496
497          myindex = myindex + arlen
498          bufsize = bufsize + arlen
499          ar%sendsize = arlen
500
501       ENDDO
502
503       IF ( rcount > 0 )  THEN
504          CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
505       ENDIF
506
507    ENDDO
508
509!
510!-- Create RMA (One Sided Communication) window for data buffer parent to
511!-- child transfer.
512!-- The buffer of MPI_GET (counterpart of transfer) can be PE-local, i.e.
513!-- it can but must not be part of the MPI RMA window. Only one RMA window is
514!-- required to prepare the data for
515!--                       parent -> child transfer on the parent side
516!-- and for
517!--                       child -> parent transfer on the child side
518    CALL pmc_alloc_mem( base_array_pc, bufsize )
519    children(childid)%totalbuffersize = bufsize * wp
520
521    winsize = bufsize * wp
522    CALL MPI_WIN_CREATE( base_array_pc, winsize, wp, MPI_INFO_NULL,             &
523                         children(childid)%intra_comm,                          &
524                         children(childid)%win_parent_child, ierr )
525
526!
527!-- Open window to set data
528    CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr )
529
530!
531!-- Second stride: set buffer pointer
532    DO  i = 1, children(childid)%inter_npes
533
534       ape => children(childid)%pes(i)
535
536       DO  j = 1, ape%nr_arrays
537
538          ar => ape%array_list(j)
539          ar%sendbuf = C_LOC( base_array_pc(ar%sendindex) )
540
541          IF ( ar%sendindex + ar%sendsize > bufsize )  THEN             
542             WRITE( message_string, '(a,i4,4i7,1x,a)' )                         &
543                    'parent buffer too small ',i,                               &
544                    ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,          &
545                    bufsize,trim(ar%name)
546             CALL message( 'pmc_s_setind_and_allocmem', 'PA0429', 3, 2, 0, 6, 0 )
547          ENDIF
548       ENDDO
549    ENDDO
550
551!
552!-- Child to parent direction
553    bufsize = 8
554
555!
556!-- First stride: compute size and set index
557    DO  i = 1, children(childid)%inter_npes
558
559       ape => children(childid)%pes(i)
560       tag = 300
561
562       DO  j = 1, ape%nr_arrays
563
564          ar => ape%array_list(j)
565
566!
567!--       Receive index from child
568          tag = tag + 1
569          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                     &
570                         children(childid)%inter_comm, MPI_STATUS_IGNORE, ierr )
571
572          IF ( ar%nrdims == 3 )  THEN
573             bufsize = MAX( bufsize, ape%nrele * ar%a_dim(4) )
574          ELSE
575             bufsize = MAX( bufsize, ape%nrele )
576          ENDIF
577          ar%recvindex = myindex
578
579        ENDDO
580
581    ENDDO
582
583!
584!-- Create RMA (one sided communication) data buffer.
585!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
586!-- the MPI RMA window
587    CALL pmc_alloc_mem( base_array_cp, bufsize, base_ptr )
588    children(childid)%totalbuffersize = bufsize * wp
589
590    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
591
592!
593!-- Second stride: set buffer pointer
594    DO  i = 1, children(childid)%inter_npes
595
596       ape => children(childid)%pes(i)
597
598       DO  j = 1, ape%nr_arrays
599          ar => ape%array_list(j)
600          ar%recvbuf = base_ptr
601       ENDDO
602
603    ENDDO
604
605 END SUBROUTINE pmc_s_setind_and_allocmem
606
607
608
609 SUBROUTINE pmc_s_fillbuffer( childid, waittime )
610
611    IMPLICIT NONE
612
613    INTEGER, INTENT(IN)             ::  childid   !<
614
615    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
616
617    INTEGER               ::  ierr     !<
618    INTEGER               ::  ij       !<
619    INTEGER               ::  ip       !<
620    INTEGER               ::  istat    !<
621    INTEGER               ::  j        !<
622    INTEGER               ::  myindex  !<
623
624    INTEGER, DIMENSION(1) ::  buf_shape
625
626    REAL(wp)                            ::  t1       !<
627    REAL(wp)                            ::  t2       !<
628    REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
629    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
630    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
631
632    TYPE(pedef), POINTER    ::  ape  !<
633    TYPE(arraydef), POINTER ::  ar   !<
634
635!
636!-- Synchronization of the model is done in pmci_synchronize.
637!-- Therefor the RMA window can be filled without
638!-- sychronization at this point and a barrier is not necessary.
639!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
640!-- pmc_c_getbuffer
641    IF ( PRESENT( waittime) )  THEN
642      t1 = pmc_time()
643      CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
644      t2 = pmc_time()
645      waittime = t2- t1
646    ENDIF
647
648    DO  ip = 1, children(childid)%inter_npes
649
650       ape => children(childid)%pes(ip)
651
652       DO  j = 1, ape%nr_arrays
653
654          ar => ape%array_list(j)
655          myindex = 1
656
657          IF ( ar%nrdims == 2 )  THEN
658
659             buf_shape(1) = ape%nrele
660             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
661             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
662             DO  ij = 1, ape%nrele
663                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
664                myindex = myindex + 1
665             ENDDO
666
667          ELSEIF ( ar%nrdims == 3 )  THEN
668
669             buf_shape(1) = ape%nrele*ar%a_dim(4)
670             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
671             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
672             DO  ij = 1, ape%nrele
673                buf(myindex:myindex+ar%a_dim(4)-1) =                            &
674                        data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i)
675                myindex = myindex + ar%a_dim(4)
676             ENDDO
677
678          ENDIF
679
680        ENDDO
681
682    ENDDO
683
684!
685!-- Buffer is filled
686    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
687
688 END SUBROUTINE pmc_s_fillbuffer
689
690
691
692 SUBROUTINE pmc_s_getdata_from_buffer( childid, waittime )
693
694    IMPLICIT NONE
695
696    INTEGER, INTENT(IN)             ::  childid      !<
697    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime     !<
698
699    INTEGER                        ::  ierr          !<
700    INTEGER                        ::  ij            !<
701    INTEGER                        ::  ip            !<
702    INTEGER                        ::  istat         !<
703    INTEGER                        ::  j             !<
704    INTEGER                        ::  myindex       !<
705    INTEGER                        ::  nr            !<
706    INTEGER                        ::  target_pe     !<
707    INTEGER(kind=MPI_ADDRESS_KIND) ::  target_disp   !<
708
709    INTEGER, DIMENSION(1)          ::  buf_shape     !<
710
711    REAL(wp)                            ::  t1       !<
712    REAL(wp)                            ::  t2       !<
713    REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
714    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
715    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
716
717    TYPE(pedef), POINTER    ::  ape  !<
718    TYPE(arraydef), POINTER ::  ar   !<
719
720
721    t1 = pmc_time()
722
723!
724!-- Wait for child to fill buffer
725    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
726    t2 = pmc_time() - t1
727    IF ( PRESENT( waittime ) )  waittime = t2
728
729!
730!-- TODO: check next statement
731!-- Fence might do it, test later
732!-- CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr)
733    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
734
735    DO  ip = 1, children(childid)%inter_npes
736
737       ape => children(childid)%pes(ip)
738
739       DO  j = 1, ape%nr_arrays
740
741          ar => ape%array_list(j)
742
743          IF ( ar%recvindex < 0 )  CYCLE
744
745          IF ( ar%nrdims == 2 )  THEN
746             nr = ape%nrele
747          ELSEIF ( ar%nrdims == 3 )  THEN
748             nr = ape%nrele * ar%a_dim(4)
749          ENDIF
750
751          buf_shape(1) = nr
752          CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
753
754!
755!--       MPI passive target RMA
756          IF ( nr > 0 )  THEN
757             target_disp = ar%recvindex - 1
758
759!
760!--          Child PEs are located behind parent PEs
761             target_pe = ip - 1 + m_model_npes
762             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                  &
763                                children(childid)%win_parent_child, ierr )
764             CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,       &
765                           MPI_REAL, children(childid)%win_parent_child, ierr )
766             CALL MPI_WIN_UNLOCK( target_pe,                                    &
767                                  children(childid)%win_parent_child, ierr )
768          ENDIF
769
770          myindex = 1
771          IF ( ar%nrdims == 2 )  THEN
772
773             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
774             DO  ij = 1, ape%nrele
775                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
776                myindex = myindex + 1
777             ENDDO
778
779          ELSEIF ( ar%nrdims == 3 )  THEN
780
781             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3))
782             DO  ij = 1, ape%nrele
783                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =      &
784                                              buf(myindex:myindex+ar%a_dim(4)-1)
785                myindex = myindex + ar%a_dim(4)
786             ENDDO
787
788          ENDIF
789
790       ENDDO
791
792    ENDDO
793
794 END SUBROUTINE pmc_s_getdata_from_buffer
795
796
797
798 SUBROUTINE get_da_names_from_child( childid )
799
800!
801!-- Get data array description and name from child
802    IMPLICIT NONE
803
804    INTEGER, INTENT(IN) ::  childid  !<
805
806    TYPE(da_namedef) ::  myname  !<
807
808    DO
809       CALL pmc_bcast( myname%couple_index, 0, comm=m_to_child_comm(childid) )
810       IF ( myname%couple_index == -1 )  EXIT
811       CALL pmc_bcast( myname%parentdesc,   0, comm=m_to_child_comm(childid) )
812       CALL pmc_bcast( myname%nameonparent, 0, comm=m_to_child_comm(childid) )
813       CALL pmc_bcast( myname%childdesc,    0, comm=m_to_child_comm(childid) )
814       CALL pmc_bcast( myname%nameonchild,  0, comm=m_to_child_comm(childid) )
815
816       CALL pmc_g_setname( children(childid), myname%couple_index,              &
817                           myname%nameonparent )
818   ENDDO
819
820 END SUBROUTINE get_da_names_from_child
821
822
823
824 SUBROUTINE pmc_s_setarray(childid, nrdims, dims, array_adr, second_adr )
825
826!
827!-- Set array for child inter PE 0
828    IMPLICIT NONE
829
830    INTEGER, INTENT(IN)               ::  childid    !<
831    INTEGER, INTENT(IN)               ::  nrdims     !<
832    INTEGER, INTENT(IN), DIMENSION(:) ::  dims       !<
833
834    TYPE(C_PTR), INTENT(IN)           :: array_adr   !<
835    TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr  !<
836
837    INTEGER ::  i  !< local counter
838
839    TYPE(pedef), POINTER    ::  ape  !<
840    TYPE(arraydef), POINTER ::  ar   !<
841
842
843    DO  i = 1, children(childid)%inter_npes
844
845       ape => children(childid)%pes(i)
846       ar  => ape%array_list(next_array_in_list)
847       ar%nrdims = nrdims
848       ar%a_dim  = dims
849       ar%data   = array_adr
850
851       IF ( PRESENT( second_adr ) )  THEN
852          ar%po_data(1) = array_adr
853          ar%po_data(2) = second_adr
854       ELSE
855          ar%po_data(1) = C_NULL_PTR
856          ar%po_data(2) = C_NULL_PTR
857       ENDIF
858
859    ENDDO
860
861 END SUBROUTINE pmc_s_setarray
862
863
864
865 SUBROUTINE pmc_s_set_active_data_array( childid, iactive )
866
867    IMPLICIT NONE
868
869    INTEGER, INTENT(IN) ::  childid   !<
870    INTEGER, INTENT(IN) ::  iactive   !<
871
872    INTEGER :: i   !<
873    INTEGER :: ip  !<
874    INTEGER :: j   !<
875
876    TYPE(pedef), POINTER    ::  ape  !<
877    TYPE(arraydef), POINTER ::  ar   !<
878
879    DO  ip = 1, children(childid)%inter_npes
880
881       ape => children(childid)%pes(ip)
882
883       DO  j = 1, ape%nr_arrays
884
885          ar => ape%array_list(j)
886          IF ( iactive == 1  .OR.  iactive == 2 )  THEN
887             ar%data = ar%po_data(iactive)
888          ENDIF
889
890       ENDDO
891
892    ENDDO
893
894 END SUBROUTINE pmc_s_set_active_data_array
895
896
897
898 SUBROUTINE set_pe_index_list( childid, mychild, index_list, nrp )
899
900    IMPLICIT NONE
901
902    INTEGER, INTENT(IN)                 ::  childid     !<
903    INTEGER, INTENT(IN), DIMENSION(:,:) ::  index_list  !<
904    INTEGER, INTENT(IN)                 ::  nrp         !<
905
906    TYPE(childdef), INTENT(INOUT)       ::  mychild     !<
907
908    INTEGER                                 :: i        !<
909    INTEGER                                 :: ierr     !<
910    INTEGER                                 :: ind      !<
911    INTEGER                                 :: indwin   !<
912    INTEGER                                 :: indwin2  !<
913    INTEGER                                 :: i2       !<
914    INTEGER                                 :: j        !<
915    INTEGER                                 :: rempe    !<
916    INTEGER(KIND=MPI_ADDRESS_KIND)          :: winsize  !<
917
918    INTEGER, DIMENSION(mychild%inter_npes)  :: remind   !<
919
920    INTEGER, DIMENSION(:), POINTER          :: remindw  !<
921    INTEGER, DIMENSION(:), POINTER          :: rldef    !<
922
923    TYPE(pedef), POINTER                    :: ape      !<
924
925!
926!-- First, count entries for every remote child PE
927    DO  i = 1, mychild%inter_npes
928       ape => mychild%pes(i)
929       ape%nrele = 0
930    ENDDO
931
932!
933!-- Loop over number of coarse grid cells
934    DO  j = 1, nrp
935       rempe = index_list(5,j) + 1   ! PE number on remote PE
936       ape => mychild%pes(rempe)
937       ape%nrele = ape%nrele + 1     ! Increment number of elements for this child PE
938    ENDDO
939
940    DO  i = 1, mychild%inter_npes
941       ape => mychild%pes(i)
942       ALLOCATE( ape%locind(ape%nrele) )
943    ENDDO
944
945    remind = 0
946
947!
948!-- Second, create lists
949!-- Loop over number of coarse grid cells
950    DO  j = 1, nrp
951       rempe = index_list(5,j) + 1
952       ape => mychild%pes(rempe)
953       remind(rempe)     = remind(rempe)+1
954       ind               = remind(rempe)
955       ape%locind(ind)%i = index_list(1,j)
956       ape%locind(ind)%j = index_list(2,j)
957    ENDDO
958
959!
960!-- Prepare number of elements for children PEs
961    CALL pmc_alloc_mem( rldef, mychild%inter_npes*2 )
962
963!
964!-- Number of child PEs * size of INTEGER (i just arbitrary INTEGER)
965    winsize = mychild%inter_npes*c_sizeof(i)*2
966
967    CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                    &
968                         mychild%intra_comm, indwin, ierr )
969
970!
971!-- Open window to set data
972    CALL MPI_WIN_FENCE( 0, indwin, ierr )
973
974    rldef(1) = 0            ! index on remote PE 0
975    rldef(2) = remind(1)    ! number of elements on remote PE 0
976
977!
978!-- Reserve buffer for index array
979    DO  i = 2, mychild%inter_npes
980       i2          = (i-1) * 2 + 1
981       rldef(i2)   = rldef(i2-2) + rldef(i2-1) * 2  ! index on remote PE
982       rldef(i2+1) = remind(i)                      ! number of elements on remote PE
983    ENDDO
984
985!
986!-- Close window to allow child to access data
987    CALL MPI_WIN_FENCE( 0, indwin, ierr )
988
989!
990!-- Child has retrieved data
991    CALL MPI_WIN_FENCE( 0, indwin, ierr )
992
993    i2 = 2 * mychild%inter_npes - 1
994    winsize = ( rldef(i2) + rldef(i2+1) ) * 2
995
996!
997!-- Make sure, MPI_ALLOC_MEM works
998    winsize = MAX( winsize, 1 )
999
1000    CALL pmc_alloc_mem( remindw, INT( winsize ) )
1001
1002    CALL MPI_BARRIER( m_model_comm, ierr )
1003    CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,      &
1004                         mychild%intra_comm, indwin2, ierr )
1005!
1006!-- Open window to set data
1007    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
1008
1009!
1010!-- Create the 2D index list
1011    DO  j = 1, nrp
1012       rempe = index_list(5,j) + 1    ! PE number on remote PE
1013       ape => mychild%pes(rempe)
1014       i2    = rempe * 2 - 1
1015       ind   = rldef(i2) + 1
1016       remindw(ind)   = index_list(3,j)
1017       remindw(ind+1) = index_list(4,j)
1018       rldef(i2)      = rldef(i2)+2
1019    ENDDO
1020
1021!
1022!-- All data are set
1023    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
1024
1025!
1026!-- Don't know why, but this barrier is necessary before windows can be freed
1027!-- TODO: find out why this is required
1028    CALL MPI_BARRIER( mychild%intra_comm, ierr )
1029
1030    CALL MPI_WIN_FREE( indwin, ierr )
1031    CALL MPI_WIN_FREE( indwin2, ierr )
1032
1033!
1034!-- TODO: check if the following idea needs to be done
1035!-- Sollte funktionieren, Problem mit MPI implementation
1036!-- https://www.lrz.de/services/software/parallel/mpi/onesided
1037!-- CALL MPI_Free_mem (remindw, ierr)
1038
1039 END SUBROUTINE set_pe_index_list
1040
1041#endif
1042 END MODULE pmc_parent
Note: See TracBrowser for help on using the repository browser.