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

Last change on this file since 2699 was 2696, checked in by kanani, 7 years ago

Merge of branch palm4u into trunk

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