source: LMDZ5/branches/IPSLCM6.0.11pre/libf/phylmd/rrtm/sutrle_mod.F90 @ 5360

Last change on this file since 5360 was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM


Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 6.0 KB
Line 
1MODULE SUTRLE_MOD
2CONTAINS
3SUBROUTINE SUTRLE(PNM)
4
5!**** *sutrle * - transposition of Legendre polynomials during set-up
6
7!     Purpose.
8!     --------
9!           transposition of Legendre polynomials during set-up
10
11!**   Interface.
12!     ----------
13!        *call* *sutrle(pnm)
14
15!        Explicit arguments :
16!        --------------------
17
18!        Implicit arguments :
19!        --------------------
20
21!     Method.
22!     -------
23!        See documentation
24
25!     Externals.
26!     ----------
27
28!     Reference.
29!     ----------
30!        ECMWF Research Department documentation of the IFS
31
32!     Author.
33!     -------
34!        MPP Group *ECMWF*
35
36!     Modifications.
37!     --------------
38!        Original : 95-10-01
39!     ------------------------------------------------------------------
40
41
42USE PARKIND1  ,ONLY : JPIM     ,JPRB
43!USE MPL_MODULE
44
45USE TPM_GEN
46USE TPM_DIM
47USE TPM_DISTR
48USE TPM_FIELDS
49USE SET2PE_MOD
50USE ABORT_TRANS_MOD
51
52IMPLICIT NONE
53
54REAL(KIND=JPRB),INTENT(IN) :: PNM(R%NSPOLEG,D%NLEI3D)
55
56!     LOCAL
57
58REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUF(:)
59REAL(KIND=JPRB), POINTER     :: ZPNM(:,:)
60INTEGER(KIND=JPIM) :: IGLLOC, ILREC, IM, INENTR, IPOS, &
61             &IRECSET, IRECV, ISEND, ISENDSET, ITAG, &
62             &JGL, JGLLOC, JM, JMLOC, JN, JROC ,IOFFT, IOFFG
63
64LOGICAL :: LLADMSG, LLEXACT
65
66!     ------------------------------------------------------------------
67
68!*       0.    Some initializations.
69!              ---------------------
70!! Workaround for obscure unwillingness to vectorize on VPP
71ZPNM => F%RPNM
72
73! Perform barrier synchronisation to guarantee all processors have
74! completed all previous communication
75
76IF( NPROC > 1 )THEN
77! CALL GSTATS(783,0)     ! MPL 3.12.08
78! CALL MPL_BARRIER(CDSTRING='SUTRLE:')
79! CALL GSTATS(783,1)
80  CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_BARRIER')
81ENDIF
82
83ALLOCATE (ZCOMBUF(NCOMBFLEN))
84
85DO JROC=1,NPRTRW-1
86
87  LLADMSG = .FALSE.
88  ITAG = MTAGLETR
89
90!*     Define PE to which data have to be sent and PE from which
91!*     data have to be received
92
93! CALL GSTATS(801,0)  ! MPL 4.12.08
94  ISEND = MYSETW-JROC
95  IRECV = MYSETW+JROC
96  IF (ISEND <= 0)     ISEND = ISEND+NPRTRW
97  IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW
98  IRECSET = IRECV
99  ISENDSET = ISEND
100  CALL SET2PE(ISEND,0,0,ISEND,MYSETV)
101  CALL SET2PE(IRECV,0,0,IRECV,MYSETV)
102
103!*   copy data to be sent into zcombuf
104
105  IPOS = 0
106  DO JM=0,R%NSMAX
107    IF (ISENDSET == D%NPROCM(JM)) THEN
108      INENTR = (D%NLATLE(MYSETW)-D%NLATLS(MYSETW)+1)*(R%NTMAX-JM+2)
109      IF (IPOS + INENTR < NCOMBFLEN) THEN
110        DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW)
111          JGLLOC = JGL - D%NLATLS(MYSETW) + 1
112          DO JN=1,R%NTMAX-JM+2
113            IPOS = IPOS + 1
114            ZCOMBUF(IPOS) = PNM(D%NPMG(JM)+JN,JGLLOC)
115          ENDDO
116        ENDDO
117      ELSE
118        DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW)
119          JGLLOC = JGL - D%NLATLS(MYSETW) + 1
120          DO JN=1,R%NTMAX-JM+2
121            IPOS = IPOS + 1
122            ZCOMBUF(IPOS) = PNM(D%NPMG(JM)+JN,JGLLOC)
123            IF (IPOS == NCOMBFLEN) THEN
124!             CALL MPL_SEND(zcombuf(1:ipos),KDEST=NPRCIDS(ISEND), &
125!              & KTAG=ITAG,CDSTRING='SUTRLE:')     ! MPL 3.12.08
126              CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_SEND')
127              IPOS = 0
128              ITAG = ITAG + 1
129              LLEXACT = (JGL == D%NLATLE(MYSETW) .AND. JN == R%NTMAX-JM+2)
130              IF (.NOT.LLEXACT) LLADMSG = .TRUE.
131            ENDIF
132          ENDDO
133        ENDDO
134      ENDIF
135    ENDIF
136  ENDDO
137
138!*   send message (if not empty or if message has been split)
139
140  IF (IPOS > 0 .OR. LLADMSG) THEN
141!   CALL MPL_SEND(ZCOMBUF(1:IPOS),KDEST=NPRCIDS(ISEND), &
142!    & KTAG=ITAG,CDSTRING='SUTRLE:')    ! MPL 3.12.08
143     CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_SEND')
144  ENDIF
145! CALL GSTATS(801,1) ! MPL 4.12.08
146
147  ILREC = 0
148  ITAG = MTAGLETR
149  IF (D%NUMP > 0.AND. D%NLATLE(IRECSET) >= D%NLATLS(IRECSET)) THEN
150
151!*   receive message (if not empty)
152
153!   CALL GSTATS(801,0)
154!   CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN),KSOURCE=NPRCIDS(IRECV), &
155!    & KTAG=ITAG,KOUNT=ILREC,CDSTRING='SUTRLE:')  ! MPL 3.12.08
156    CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_RECV')
157
158!*   copy data from buffer to f%rpnm
159
160    IPOS = 0
161    DO JMLOC=1,D%NUMP
162      JM = D%MYMS(JMLOC)
163      INENTR = (D%NLATLE(IRECSET)-D%NLATLS(IRECSET)+1)*(R%NTMAX-JM+2)
164      IOFFT = D%NPMT(JM)
165      IF (IPOS + INENTR < NCOMBFLEN) THEN
166        DO JGL=D%NLATLS(IRECSET),D%NLATLE(IRECSET)
167          DO JN=1,R%NTMAX-JM+2
168            IPOS = IPOS + 1
169            ZPNM(JGL,IOFFT+JN) = ZCOMBUF(IPOS)
170          ENDDO
171        ENDDO
172      ELSE
173        DO JGL=D%NLATLS(IRECSET),D%NLATLE(IRECSET)
174          DO JN=1,R%NTMAX-JM+2
175            IPOS = IPOS + 1
176            ZPNM(JGL,IOFFT+JN) = ZCOMBUF(IPOS)
177            IF (IPOS == NCOMBFLEN) THEN
178              ITAG = ITAG + 1
179!             CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN), &
180!              & KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
181!              & KOUNT=ILREC,CDSTRING='SUTRLE:')    ! MPL 3.12.08
182              CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_RECV')
183              IPOS = 0
184            ENDIF
185          ENDDO
186        ENDDO
187      ENDIF
188    ENDDO
189!   CALL GSTATS(801,1)  ! MPL 4.12.08
190
191!*    check received message length
192
193    IF (ILREC /= IPOS) THEN
194      WRITE(NOUT,*)' SUTRLE: ILREC,IPOS,NCOMBLEN ',ILREC,IPOS,NCOMBFLEN
195      CALL ABORT_TRANS(' SUTRLE:RECEIVED MESSAGE LENGTH DOES NOT MATCH')
196    ENDIF
197  ENDIF
198
199! Perform barrier synchronisation to guarantee all processors have
200! completed communication for this jroc loop iteration
201
202! CALL MPL_BARRIER(CDSTRING='SUTRLE:')      ! MPL 3.12.08
203  CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_BARRIER')
204
205ENDDO
206
207!*    copy data from pnm to rpnm
208
209!CALL GSTATS(1803,0)   ! MPL 4.12.08
210!cjfe OMP not efficient in that case
211!cjfe!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jmloc,im,iofft,ioffg,jgl,iglloc,jn)
212DO JMLOC=1,D%NUMP
213  IM = D%MYMS(JMLOC)
214  IOFFT = D%NPMT(IM)
215  IOFFG = D%NPMG(IM)
216  DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW)
217    IGLLOC = JGL-D%NLATLS(MYSETW)+1
218    DO JN=1,R%NTMAX-IM+2
219      ZPNM(JGL,IOFFT+JN) = PNM(IOFFG+JN,IGLLOC)
220    ENDDO
221  ENDDO
222ENDDO
223!cjfe!$OMP END PARALLEL DO
224!CALL GSTATS(1803,1) ! MPL 4.12.08
225
226DEALLOCATE (ZCOMBUF)
227
228END SUBROUTINE SUTRLE
229END MODULE SUTRLE_MOD
Note: See TracBrowser for help on using the repository browser.