New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_io_fdir.F90 in trunk/NEMO/OPA_SRC – NEMO

source: trunk/NEMO/OPA_SRC/lib_io_fdir.F90 @ 3

Last change on this file since 3 was 3, checked in by opalod, 20 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.7 KB
Line 
1MODULE lib_io_fdir
2   !!======================================================================
3   !!   ???
4   !!======================================================================
5#if defined key_fdir
6   !!======================================================================
7   !!  IO Routines for OPA
8   !!
9   !!  read2     read a direct access 2D field (jpiglo,jpjglo)
10   !!  read2d    read a direct access 2D field (jpidta,jpjdta)
11   !!  read3     read a direct access 3D field (jpiglo,jpjglo,jpk)
12   !!  read3d    read a direct access 3D field (jpidta,jpjdta,jpk)
13   !!
14   !!  write2    write a direct access 2D field (jpiglo,jpjglo)
15   !!  write3    write a direct access 3D field (jpiglo,jpjglo,jpk)
16   !!  write4    write a 4bytes direct access 2D field (jpiglo,jpjglo)
17   !!
18   !!======================================================================
19   !! * Modules used
20   USE dom_oce         ! ocean space and time domain
21   USE lib_mpp         ! distributed memory computing library
22
23   IMPLICIT NONE
24
25   !! * Module variables
26   INTEGER, PARAMETER ::            &
27      jpkmod  = 1 + (jpk-1)/jpnij      ! used for mpp outputs
28
29   REAL(wp), DIMENSION(jpi,jpj,jpnij,jpkmod) ::   &
30      tabio              ! i/o workspace array
31   REAL(wp), DIMENSION(jpiglo,jpjglo) ::   &
32      tabglo             ! global auxilary array
33   REAL(wp), DIMENSION(jpidta,jpjdta) ::   &
34      tabdta             ! global auxilary array
35   !!----------------------------------------------------------------------
36   !!   OPA 9.0 , LODYC-IPSL  (2003)
37   !!----------------------------------------------------------------------
38
39CONTAINS
40
41   SUBROUTINE read2( kunit, ptab, kdim, krec )
42   !!---------------------------------------------------------------------
43   !!                  ***  ROUTINE read2  ***
44   !!     
45   !! ** Purpose :   Opa standard input for a 2D array
46   !!
47   !! ** Method : - Read a binary array ( direct access file )
48   !!      If key_mpp is used, write with an auxilary array
49   !!
50   !! History
51   !!      original  : 93-09 (M. Imbard)
52   !!      additions : 96-05 (J. Escobar)
53   !!----------------------------------------------------------------------
54   !! * Arguments
55      INTEGER , INTENT( in  ) ::   &
56         kunit           ! output unit
57      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) ::   &
58         ptab            ! variable array
59      INTEGER , INTENT( in  ) ::   &
60         kdim ,       &  ! record length
61         krec            ! record unit for direct access file
62
63#if defined key_mpp
64   !! * Local declarations
65      INTEGER ji, jj, jproc   ! dummy loop indices
66      INTEGER imess, ic
67      INTEGER ilci, ilcj, iilb, ijlb
68   !!---------------------------------------------------------------------
69
70   ! 1. Read global array
71   ! --------------------
72
73   ! only the main processor
74
75      IF( narea == 1 ) THEN
76         READ(kunit,REC=kdim*(krec-1)+1) tabglo
77         DO jproc = 1, jpnij
78            ilci = nlcit (jproc)
79            ilcj = nlcjt (jproc)
80            iilb = nimppt(jproc)
81            ijlb = njmppt(jproc)
82            DO jj = 1, ilcj
83               DO ji = 1, ilci
84                  tabio(ji,jj,jproc,1) = tabglo(ji+iilb-1,jj+ijlb-1)
85               END DO
86             END DO
87         END DO
88      ENDIF
89      CALL mppsync
90
91   ! 2. Scaterring of auxilary array
92   ! -------------------------------
93
94      CALL mppscatter( tabio, 1, 0, ptab )
95      CALL mppsync
96
97      ! mask
98      DO jj = nlcj+1, jpj
99         DO ji = 1, nlci
100            ptab(ji,jj) = 0.e0
101         END DO
102      END DO
103      DO ji = nlci+1, jpi
104         ptab(ji,:) = 0.e0
105      END DO
106      CALL mppsync
107
108#  else
109     READ(kunit,REC=kdim*(krec-1)+1) ptab
110#endif
111
112   END SUBROUTINE read2
113
114
115   SUBROUTINE read2d( kunit, ptab, kdim, krec )
116   !!---------------------------------------------------------------------
117   !!                  ***  ROUTINE read2D  ***
118   !!
119   !! ** Purpose :   Opa standard input for a 2D data array
120   !!     (its possible to read only a subdomain - zoom )
121   !!
122   !! ** Method  :   Read a binary array ( direct access file )
123   !!      If key_mpp is used, write with an auxilary array
124   !!
125   !! ** Action :
126   !!
127   !! History :
128   !!      original  : 93-09 (M. Imbard)
129   !!      additions : 96-05 (j. Escobar)
130   !!      additions : 98-11 (J. Vialard) vpp
131   !!----------------------------------------------------------------------
132   !! * Arguments
133      INTEGER , INTENT( in  ) ::   &
134         kunit           ! output unit
135      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) ::   &
136         ptab            ! variable array
137      INTEGER , INTENT( in  ) ::   &     
138         kdim ,       &  ! record length
139         krec            ! record unit for direct access file
140
141#if defined key_mpp
142      INTEGER ji, jj, jproc
143      INTEGER imess, ic
144      INTEGER ilci, ilcj, iilb, ijlb
145   !!---------------------------------------------------------------------
146
147
148   ! 1. Read global array
149   ! --------------------
150
151   ! only the main processor
152
153      IF( narea == 1 ) THEN
154         READ(kunit,REC=kdim*(krec-1)+1) tabdta
155         DO jproc=1,jpnij
156            ilci = nlcit (jproc)
157            ilcj = nlcjt (jproc)
158            iilb = nimppt(jproc)
159            ijlb = njmppt(jproc)
160            DO jj = 1, ilcj
161               DO ji = 1, ilci
162                  tabio(ji,jj,jproc,1)=tabdta(ji+jpizoom-1+iilb-1,jj+jpjzoom-1+ijlb-1)
163               END DO
164            END DO
165         END DO
166      ENDIF
167      CALL mppsync
168
169   ! 2. Scaterring of auxilary array
170   ! -------------------------------
171
172      CALL mppscatter( tabio, 1, 0, ptab )
173
174   ! mask
175
176      DO jj = nlcj+1, jpj
177         DO ji = 1, nlci
178            ptab(ji,jj) = 0.e0
179         END DO
180      END DO
181      DO ji = nlci+1, jpi
182         ptab(ji,:) = 0.e0
183      END DO
184      CALL mppsync
185
186#  else
187
188      INTEGER ji, jj
189
190      READ(kunit,REC=kdim*(krec-1)+1) tabdta
191      DO jj = 1, jpj
192        DO ji = 1, jpi
193          ptab(ji,jj) = tabdta( mig(ji), mjg(jj) )
194        END DO
195      END DO
196#endif
197
198  END SUBROUTINE read2d
199
200
201   SUBROUTINE read3( kunit, ptab, krec )
202   !!---------------------------------------------------------------------
203   !!                  ***  ROUTINE read3  ***
204   !!                 
205   !! ** Purpose :   Opa standard input for a 3d array
206   !!
207   !! ** Method  :   Read a binary array ( direct access FILE )
208   !!      If key_mpp is used, write with an auxilary array
209   !!
210   !! ** Action :
211   !!
212   !! History :
213   !!      original  : 93-09 (M. Imbard)
214   !!----------------------------------------------------------------------
215   !! * Arguments
216      INTEGER , INTENT( in  ) ::   &
217         kunit           ! output unit
218      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   &
219         ptab            ! variable array
220      INTEGER , INTENT( in  ) ::   &     
221         krec            ! record unit for direct access file
222
223#if defined key_mpp
224      INTEGER ji, jj, jk, jproc
225      INTEGER ikloc, ikpe
226      INTEGER ilci, ilcj, iilb, ijlb
227   !!---------------------------------------------------------------------
228
229
230   ! 1. Read horizontal slab by horizontal slab
231   ! -------------------------------------------
232   ! each slab is associed with a processor
233   ! the input is read in a auxilary array
234
235      DO jk = 1, jpk
236        ikloc = 1 + (jk-1) / jpnij
237        ikpe  = 1 + MOD( jk-1, jpnij )
238        IF( narea == ikpe ) THEN
239            READ(kunit,REC=jpk*(krec-1)+jk) tabglo
240            DO jproc = 1, jpnij
241              ilci = nlcit (jproc)
242              ilcj = nlcjt (jproc)
243              iilb = nimppt(jproc)
244              ijlb = njmppt(jproc)
245              DO jj = 1, ilcj
246                DO ji = 1, ilci
247                  tabio(ji,jj,jproc,ikloc) = tabglo(ji+iilb-1,jj+ijlb-1)
248                END DO
249              END DO
250            END DO
251        ENDIF
252      END DO
253      CALL mppsync
254
255   ! 2. Scaterring of auxilary array
256   ! -------------------------------
257
258      DO jk = 1,jpk
259        ikloc = 1 + (jk-1) / jpnij
260        ikpe  = 1 + MOD( jk-1, jpnij )
261        CALL mppscatter( tabio(1,1,1,ikloc), jk, ikpe-1, ptab(1,1,jk) )
262
263   ! mask
264
265        DO jj = nlcj+1, jpj
266          DO ji = 1, nlci
267            ptab(ji,jj,jk) = 0.e0
268          END DO
269        END DO
270        DO ji = nlci+1, jpi
271          DO jj = 1, jpj
272            ptab(ji,jj,jk) = 0.e0
273          END DO
274        END DO
275      END DO
276      CALL mppsync
277
278#  else
279
280      INTEGER jk
281
282      DO jk = 1, jpk
283         READ(kunit,REC=jpk*(krec-1)+jk) tabglo
284         ptab(:,:,jk) = tabglo(:,:)
285      END DO
286#endif
287
288   END SUBROUTINE read3
289
290
291   SUBROUTINE read3d( kunit, ptab, krec )
292   !!---------------------------------------------------------------------
293   !!                  ***  ROUTINE read3D  ***
294   !! 
295   !! ** Purpose :   Opa standard input for a 3D data array
296   !!     (its possible to read only a subdomain - zoom )
297   !!
298   !! ** Method  :   Read a binary array ( direct access file )
299   !!      IF key_mpp is used, write with an auxilary array
300   !!
301   !! ** Action :
302   !!
303   !! History :
304   !!      original  : 93-09 (M. Imbard)
305   !!      additions : 98-11 (J. Vialard) vpp
306   !!----------------------------------------------------------------------
307   !! * Arguments
308      INTEGER , INTENT( in  ) ::   &
309         kunit           ! output unit
310      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   &
311         ptab            ! variable array
312      INTEGER , INTENT( in  ) ::   &     
313         krec            ! record unit for direct access file
314
315#if defined key_mpp
316      INTEGER ji, jj, jk, jproc
317      INTEGER ikloc, ikpe
318      INTEGER ilci, ilcj, iilb, ijlb
319   !!---------------------------------------------------------------------
320
321
322   ! 1. Read horizontal slab by horizontal slab
323   ! -------------------------------------------
324   ! each slab is associed with a processor
325   ! the input is read in a auxilary array
326
327      DO jk = 1,jpk
328        ikloc = 1 + (jk-1) / jpnij
329        ikpe  = 1 + MOD( jk-1, jpnij )
330        IF( narea == ikpe ) THEN
331            READ(kunit,REC=jpk*(krec-1)+jk) tabdta
332            DO jproc = 1, jpnij
333              ilci = nlcit (jproc)
334              ilcj = nlcjt (jproc)
335              iilb = nimppt(jproc)
336              ijlb = njmppt(jproc)
337              DO jj = 1, ilcj
338                DO ji = 1, ilci
339                  tabio(ji,jj,jproc,ikloc) = tabdta(ji+jpizoom-1+iilb-1,jj+jpjzoom-1+ijlb-1)
340                END DO
341              END DO
342            END DO
343        ENDIF
344      END DO
345      CALL mppsync
346
347   ! 2. Scaterring of auxilary array
348   ! -------------------------------
349
350      DO jk = 1, jpk
351         ikloc = 1 + (jk-1) / jpnij
352         ikpe  = 1 + MOD( jk-1, jpnij )
353         CALL mppscatter( tabio(1,1,1,ikloc), jk, ikpe-1, ptab(1,1,jk) )
354
355   ! mask
356
357         DO jj = nlcj+1, jpj
358            DO ji = 1,nlci
359               ptab(ji,jj,jk) = 0.e0
360            END DO
361         END DO
362         DO ji = nlci+1, jpi
363            ptab(ji,:,jk) = 0.e0
364         END DO
365      END DO
366      CALL mppsync
367
368#  else
369
370      INTEGER ji, jj, jk
371
372      DO jk = 1, jpk
373         READ(kunit,REC=jpk*(krec-1)+jk) tabdta
374         DO jj = 1, jpj
375            DO ji = 1, jpi
376               ptab(ji,jj,jk) = tabdta( mig(ji), mjg(jj) )
377            END DO
378         END DO
379      END DO
380#endif
381
382   END SUBROUTINE read3d
383
384
385   SUBROUTINE write2( kunit, ptab, kdim, krec )
386   !!---------------------------------------------------------------------
387   !!                  ***  ROUTINE write2  ***
388   !!
389   !! ** Purpose :   OPA standard output for a 2D array
390   !!
391   !! ** Method  :   write a binary array
392   !!      If key_mpp is used, write with an auxilary array
393   !!
394   !! History :
395   !!       original  : 93-09 (M. Imbard)
396   !!       additions : 96-05 (J. Escobar)
397   !!----------------------------------------------------------------------
398   !! * Arguments
399      INTEGER , INTENT( in  ) ::   &
400         kunit           ! output unit
401      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) ::   &
402         ptab            ! variable array
403      INTEGER , INTENT( in  ) ::   &     
404         kdim ,       &  ! record length
405         krec            ! record unit for direct access file
406
407#if defined key_mpp
408      INTEGER ji,jj,jproc
409      INTEGER ildi,ilei,ildj,ilej
410      INTEGER iilb,ijlb
411   !!---------------------------------------------------------------------
412
413
414      tabglo(:,:) = 0.e0
415
416   ! 1. Receive of each subdomain array
417   ! ----------------------------------
418   ! processor position dependance
419   ! the main processor 0 receive each contribution
420
421      CALL mppgather( ptab, 1, 0, tabio )
422      CALL mppsync
423
424
425   ! 2. Write
426   ! --------
427
428   ! only the main processor
429
430      IF( narea == 1 ) THEN
431
432   !  write in an global auxilary array
433         DO jproc = 1, jpnij
434            ildi = nldit (jproc)   
435            ilei = nleit (jproc)   
436            ildj = nldjt (jproc)   
437            ilej = nlejt (jproc)   
438            iilb = nimppt(jproc)
439            ijlb = njmppt(jproc)
440            DO jj = ildj, ilej
441               DO ji = ildi, ilei
442                  tabglo(ji+iilb-1,jj+ijlb-1) = tabio(ji,jj,jproc,1)
443               END DO
444            END DO
445         END DO
446
447   ! global periodicity
448         IF( jperio == 1 ) THEN
449            tabglo(  1   ,:) = tabglo(jpiglo-1,:)
450            tabglo(jpiglo,:) = tabglo(   2    ,:)
451         ENDIF
452
453   ! write
454          WRITE(kunit,REC=kdim*(krec-1)+1) tabglo
455
456      ENDIF
457
458      CALL mppsync
459
460#  else
461      WRITE(kunit,REC=kdim*(krec-1)+1) ptab
462#endif
463
464   END SUBROUTINE write2
465
466
467   SUBROUTINE write3( kunit, ptab, krec )
468   !!---------------------------------------------------------------------
469   !!                  ***  ROUTINE write3  ***
470   !!             
471   !! ** Purpose :   OPA standard output for a 3D array
472   !!
473   !! ** Method  :   write a binary array
474   !!      If key_mpp is used, write with an auxilary array
475   !!
476   !! ** Action :
477   !!
478   !! History :
479   !!       original  : 93-09 (M. Imbard)
480   !!       additions : 96-05 (J. Escobar)
481   !!----------------------------------------------------------------------
482   !! * Arguments
483      INTEGER , INTENT( in  ) ::   &
484         kunit           ! output unit
485      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   &
486         ptab            ! variable array
487      INTEGER , INTENT( in  ) ::   &     
488         krec            ! record unit for direct access file
489
490#if defined key_mpp
491      INTEGER ji,jj,jk,jproc
492      INTEGER ikloc,ikpe
493      INTEGER ildi,ilei,ildj,ilej
494      INTEGER iilb,ijlb
495   !!---------------------------------------------------------------------
496
497      tabglo(:,:) = 0.e0
498
499
500   ! 1. Receive of each subdomain array
501   ! ----------------------------------
502   ! processor position dependance
503   ! each processor receive the vertical slab which is attributed to it
504
505      DO jk = 1, jpk
506         ikloc = 1 + (jk-1) / jpnij
507         ikpe  = 1 + MOD( jk-1, jpnij )
508         CALL mppgather( ptab(1,1,jk), jk, ikpe-1, tabio(1,1,1,ikloc) )
509      END DO
510      CALL mppsync
511
512
513   ! 2. Write horizontal slab by horizontal slab
514   ! -------------------------------------------
515
516      DO jk = 1, jpk
517         ikloc = 1 + (jk-1) / jpnij
518         ikpe  = 1 + MOD( jk-1, jpnij )
519         IF( narea == ikpe ) THEN
520
521   !  write in an global auxilary array
522
523            DO jproc = 1, jpnij
524               ildi = nldit (jproc)   
525               ilei = nleit (jproc)   
526               ildj = nldjt (jproc)   
527               ilej = nlejt (jproc)   
528               iilb = nimppt(jproc)
529               ijlb = njmppt(jproc)
530               DO jj = ildj,ilej
531                  DO ji = ildi,ilei
532                     tabglo(ji+iilb-1,jj+ijlb-1) = tabio(ji,jj,jproc,ikloc)
533                  END DO
534               END DO
535            END DO
536
537   ! global periodicity
538
539            IF( jperio == 1 ) THEN
540               tabglo(  1   ,:) = tabglo(jpiglo-1,:)
541               tabglo(jpiglo,:) = tabglo(   2    ,:)
542            ENDIF
543
544   ! write
545
546            WRITE(kunit,REC=jpk*(krec-1)+jk) tabglo
547        ENDIF
548      END DO
549      CALL mppsync
550
551#  else
552
553      INTEGER  ::   ji,jj,jk
554      REAL(wp) ::   ztab(jpi,jpj)
555
556      DO jk = 1,jpk
557         ztab(:,:) = ptab(:,:,jk)
558         WRITE(kunit,REC=jpk*(krec-1)+jk) ztab
559      END DO
560#endif
561
562      END SUBROUTINE write3
563
564
565      SUBROUTINE write4( kunit, ptab, krec )
566   !!---------------------------------------------------------------------
567   !!                  ***  ROUTINE write4  ***
568   !!       
569   !! ** Purpose :   OPA ieee 4 bytes output for a 3D array
570   !!
571   !! ** Method  :   write a binary array
572   !!      If key_mpp is used, write with an auxilary array
573   !!
574   !! History :
575   !!       original  : 93-09 (M. Imbard)
576   !!       additions : 96-05 (J. Escobar)
577   !!      additions : 98-11 (J. Vialard) vpp
578   !!----------------------------------------------------------------------
579   !! * Arguments
580      INTEGER , INTENT( in  ) ::   &
581         kunit,       &  ! output unit
582         krec            ! record unit for direct access file
583      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   &
584         ptab            ! variable array
585
586#if defined key_mpp
587   !! * Local declarations
588      INTEGER jk, jproc
589      INTEGER ikloc, ikpe
590      INTEGER ildi,ilei,ildj,ilej
591      INTEGER iilb,ijlb
592   !!---------------------------------------------------------------------
593
594      tabglo(:,:) = 0.e0
595
596
597   ! 1. Receive of each subdomain array
598   ! ----------------------------------
599   ! processor position dependance
600   ! each processor receive the vertical slab which is attributed to it
601
602      DO jk = 1, jpk
603         ikloc = 1 + (jk-1) / jpnij
604         ikpe  = 1 + MOD( jk-1, jpnij )
605         CALL mppgather( ptab(1,1,jk), jk, ikpe-1, tabio(1,1,1,ikloc) )
606      END DO
607      CALL mppsync
608
609
610   ! 2. Write horizontal slab by horizontal slab
611   ! -------------------------------------------
612
613      DO jk = 1, jpk
614         ikloc = 1 + ( jk - 1 ) / jpnij
615         ikpe  = 1 + MOD( jk-1, jpnij )
616         IF( narea == ikpe ) THEN
617
618         ! write in an global auxilary array
619            DO jproc = 1, jpnij
620               ildi = nldit (jproc)   
621               ilei = nleit (jproc)   
622               ildj = nldjt (jproc)   
623               ilej = nlejt (jproc)   
624               iilb = nimppt(jproc)
625               ijlb = njmppt(jproc)
626               DO jj = ildj, ilej
627                  DO ji = ildi, ilei
628                     tabglo(ji+iilb-1,jj+ijlb-1) = tabio(ji,jj,jproc,ikloc)
629                  END DO
630               END DO
631            END DO
632
633         ! global periodicity
634            IF( jperio == 1 ) THEN
635               tabglo(  1   ,:) = tabglo(jpiglo-1,:)
636               tabglo(jpiglo,:) = tabglo(   2    ,:)
637            ENDIF
638
639   ! write
640            WRITE(kunit,REC=jpk*(krec-1)+jk) tabglo
641        ENDIF
642      END DO
643      CALL mppsync
644
645#  else
646
647      INTEGER jk
648      REAL(wp), DIMENSION(jpi,jpj) ::   ztab
649
650      DO jk = 1, jpk
651         ztab(:,:) = ptab(:,:,jk)
652         WRITE(kunit,REC=jpk*(krec-1)+jk) ztab
653      END DO
654#endif
655
656   END SUBROUTINE write4
657
658   !!======================================================================
659#endif
660END MODULE lib_io_fdir
Note: See TracBrowser for help on using the repository browser.