pkg/mdsio/mdsio_pass_r4tors.F

08e96a842a Jean*0001 #include "MDSIO_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 C- modification: no need to edit the 4 scr files mdsio_pass_r{4,8}tor{l,s}.F :
                0005 C        from the 1rst src file (mdsio_pass_r4torl.F), can update the 3 others
                0006 C        using the script "derive_other_types".
                0007 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0008
                0009 CBOP
                0010 C !ROUTINE: MDS_PASS_R4toRS
                0011 C !INTERFACE:
f1a06a1eb2 Jean*0012       SUBROUTINE MDS_PASS_R4toRS(
                0013      U                            buffer, arrFld,
                0014      I                            oLi, oLj, nNz, kLo, kSize,
9a33636256 Jean*0015      I                            biArg, bjArg, copyTo, myThid )
08e96a842a Jean*0016
                0017 C !DESCRIPTION:
0e6a4460e5 Ivan*0018 C     Transfer 3-D real*4 buffer to 3-D RS model array, or the reverse,
                0019 C      depending on "copyTo" value. Apply transfer to tile biArg,bjArg
9a33636256 Jean*0020 C      only or to all myThid tiles if called with biArg=bjArg=0.
08e96a842a Jean*0021
                0022 C     !USES:
                0023       IMPLICIT NONE
                0024
                0025 C Global variables / common blocks
                0026 #include "EEPARAMS.h"
                0027 #include "SIZE.h"
                0028
                0029 C     !INPUT/OUTPUT PARAMETERS:
                0030 C Routine arguments
8decba0243 Jean*0031 C buffer  (real*4) :: buffer 3-D array (Input/Output if copyTo=T/F)
                0032 C arrFld   ( RS )  :: model 3-D tiled array (Output/Input if copyTo=T/F)
f1a06a1eb2 Jean*0033 C oLi     (integer):: Overlap size (dim-1) of buffer to copy - to/from - arrFld
                0034 C oLj     (integer):: Overlap size (dim-2) of buffer to copy - to/from - arrFld
8decba0243 Jean*0035 C nNz     (integer):: Number of levels to - fill in / extract from - arrFld
                0036 C kLo     (integer):: 1rst level to - fill in / extract from - arrFld
                0037 C kSize   (integer):: third dimension of 3-D array "arrFld"
                0038 C biArg   (integer):: tile X-index to - fill in / extract from - tiled buffer
                0039 C bjArg   (integer):: tile Y-index to - fill in / extract from - tiled buffer
08e96a842a Jean*0040 C copyTo  (logical):: if =T, copy 2-D -> 3-D ; if =F: copy 2-D <- 3-D
                0041 C myThid  (integer):: my Thread Id number
f1a06a1eb2 Jean*0042       INTEGER oLi, oLj
8decba0243 Jean*0043       INTEGER nNz, kSize
f1a06a1eb2 Jean*0044       Real*4 buffer(1-oLi:sNx+oLi,1-oLj:sNy+oLj,nNz,nSx,nSy)
8decba0243 Jean*0045       _RS    arrFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,kSize,nSx,nSy)
                0046       INTEGER kLo
9a33636256 Jean*0047       INTEGER biArg
                0048       INTEGER bjArg
08e96a842a Jean*0049       LOGICAL copyTo
                0050       INTEGER myThid
                0051
                0052 C !LOCAL VARIABLES:
8decba0243 Jean*0053 C   i,j,k :: loop indices
08e96a842a Jean*0054 C   bi,bj :: tile indices
8decba0243 Jean*0055       INTEGER i,j,k,bi,bj
                0056       INTEGER kLev
08e96a842a Jean*0057 CEOP
f1a06a1eb2 Jean*0058       IF ( oLi.LT.0 .OR. oLi.GT.OLx .OR.
                0059      &     oLj.LT.0 .OR. oLj.GT.OLy ) THEN
                0060         STOP 'ABNORMAL END: MDS_PASS_R4toRS invalid oLi,oLj Arg'
                0061       ENDIF
08e96a842a Jean*0062
9a33636256 Jean*0063       IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
                0064         IF ( copyTo ) THEN
                0065           DO bj = myByLo(myThid), myByHi(myThid)
                0066            DO bi = myBxLo(myThid), myBxHi(myThid)
8decba0243 Jean*0067             DO k=1,nNz
                0068              kLev = kLo+k-1
f1a06a1eb2 Jean*0069              DO j=1-oLj,sNy+oLj
                0070               DO i=1-oLi,sNx+oLi
8decba0243 Jean*0071                 arrFld(i,j,kLev,bi,bj) = buffer(i,j,k,bi,bj)
08e96a842a Jean*0072               ENDDO
9a33636256 Jean*0073              ENDDO
8decba0243 Jean*0074             ENDDO
9a33636256 Jean*0075            ENDDO
08e96a842a Jean*0076           ENDDO
9a33636256 Jean*0077         ELSE
                0078           DO bj = myByLo(myThid), myByHi(myThid)
                0079            DO bi = myBxLo(myThid), myBxHi(myThid)
8decba0243 Jean*0080             DO k=1,nNz
                0081              kLev = kLo+k-1
f1a06a1eb2 Jean*0082              DO j=1-oLj,sNy+oLj
                0083               DO i=1-oLi,sNx+oLi
8decba0243 Jean*0084                 buffer(i,j,k,bi,bj) = arrFld(i,j,kLev,bi,bj)
08e96a842a Jean*0085               ENDDO
9a33636256 Jean*0086              ENDDO
8decba0243 Jean*0087             ENDDO
9a33636256 Jean*0088            ENDDO
08e96a842a Jean*0089           ENDDO
9a33636256 Jean*0090         ENDIF
                0091       ELSEIF ( biArg.GE.1 .AND. biArg.LE.nSx
                0092      &   .AND. bjArg.GE.1 .AND. bjArg.LE.nSy ) THEN
                0093         bi = biArg
                0094         bj = bjArg
                0095         IF ( copyTo ) THEN
8decba0243 Jean*0096           DO k=1,nNz
                0097             kLev = kLo+k-1
f1a06a1eb2 Jean*0098             DO j=1-oLj,sNy+oLj
                0099               DO i=1-oLi,sNx+oLi
8decba0243 Jean*0100                 arrFld(i,j,kLev,1,1) = buffer(i,j,k,bi,bj)
9a33636256 Jean*0101               ENDDO
                0102             ENDDO
8decba0243 Jean*0103           ENDDO
9a33636256 Jean*0104         ELSE
8decba0243 Jean*0105           DO k=1,nNz
                0106             kLev = kLo+k-1
f1a06a1eb2 Jean*0107             DO j=1-oLj,sNy+oLj
                0108               DO i=1-oLi,sNx+oLi
8decba0243 Jean*0109                 buffer(i,j,k,bi,bj) = arrFld(i,j,kLev,1,1)
9a33636256 Jean*0110               ENDDO
                0111             ENDDO
8decba0243 Jean*0112           ENDDO
9a33636256 Jean*0113         ENDIF
                0114       ELSE
                0115         STOP 'ABNORMAL END: MDS_PASS_R4toRS invalid bi,bj Arg'
08e96a842a Jean*0116       ENDIF
                0117
                0118       RETURN
                0119       END