source: CPL/oasis3/trunk/src/mod/oasis3/src/mozaic.f @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago

Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).

File size: 5.7 KB
Line 
1      SUBROUTINE mozaic (pfldn, ksizn, pfldo, ksizo,
2     $                   cdfic, kunit, cdgrd, knumb,
3     $                   pwork, kwork, knbor, ldread)
4C****
5C               *****************************
6C               * OASIS ROUTINE  -  LEVEL 3 *
7C               * -------------     ------- *
8C               *****************************
9C
10C**** *mozaic* - Mapping interpolation
11C
12C     Purpose:
13C     -------
14C     Do simple mapping interpolation from a source to a target grid
15C
16C**   Interface:
17C     ---------
18C       *CALL*  *mozaic (pfildn, ksizn, pfildo, ksizo, cdfic, kunit,
19C                        cdgrd. knumb, pwork, kwork, knbor, ldread)*
20C
21C     Input:
22C     -----
23C                pfldo  : field on source grid (real 1D)
24C                ksizn  : size of field array on target grid(integer)
25C                ksizo  : size of field array on source grid(integer)
26C                kunit  : logical unit numbers for mapping file (integer)
27C                cdfic  : filename for mapping data (character)
28C                cdgrd  : locator to read mapping data in cdfic (character)
29C                knumb  : mapping dataset identity number (integer)
30C                pwork  : temporary array to read mapping weights (real 2D)
31C                kwork  : temporary array to read mapping array (integer 2D)
32C                knbor  : maximum number of source grid neighbors with non zero
33C                         intersection with a target grid-square (integer)
34C                ldread : logical flag to read mapping data
35C
36C     Output:
37C     ------
38C                pfldn  : field on target grid (real 1D)
39C
40C     Workspace:
41C     ---------
42C     None
43C
44C     Externals:
45C     ---------
46C     locrint
47C
48C     Reference:
49C     ---------
50C     See OASIS manual (1995)
51C
52C     History:
53C     -------
54C       Version   Programmer     Date      Description
55C       -------   ----------     ----      ----------- 
56C       2.0       L. Terray      96/02/01  created
57C       2.1       L. Terray      96/08/05  modified: Add logical flag to
58C                                          read adresses and weights
59C       2.3       S. Valcke      99/04/30  added: printing levels
60C       2.4       S. Valcke      2K/02/05  corrected for overflow pfldo(0)
61C
62C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
63C
64C* ---------------------------- Include files ---------------------------
65C
66      USE mod_kinds_oasis
67      USE mod_unit
68      USE mod_printing
69C
70C* ---------------------------- Argument declarations -------------------
71C
72      REAL (kind=ip_realwp_p) pfldn(ksizn), pfldo(ksizo), 
73     $    pwork(knbor,ksizn)
74      INTEGER (kind=ip_intwp_p) kwork(knbor,ksizn)
75      CHARACTER*8 cdfic, cdgrd
76      LOGICAL ldread
77C
78C* ---------------------------- Local declarations ----------------------
79C
80      CHARACTER*8 clweight, cladress
81C
82C* ---------------------------- Poema verses ----------------------------
83C
84C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
85C
86C*    1. Initialization
87C        --------------
88C
89      IF (nlogprt .GE. 2) THEN
90          WRITE (UNIT = nulou,FMT = *) ' '
91          WRITE (UNIT = nulou,FMT = *) ' '
92          WRITE (UNIT = nulou,FMT = *) 
93     $    '           ROUTINE mozaic  -  Level 3'
94          WRITE (UNIT = nulou,FMT = *) 
95     $    '           **************     *******'
96          WRITE (UNIT = nulou,FMT = *) ' '
97          WRITE (UNIT = nulou,FMT = *) ' grid mapping interpolation'
98          WRITE (UNIT = nulou,FMT = *) ' '
99          WRITE (UNIT = nulou,FMT = *) ' '
100      ENDIF
101C
102C* initialize error flag for I/O routine
103C
104      iflag = 0
105C
106C
107C*    2. Read mapping data the first time
108C        --------------------------------
109C
110      IF (ldread) THEN
111C
112C* Initialize locators and array sizes
113C
114          WRITE(clweight,'(''WEIGHTS'',I1)') knumb
115          WRITE(cladress,'(''ADRESSE'',I1)') knumb
116          isize = ksizn * knbor
117C
118C* Adress of overlapped points on source grid
119C
120          CALL locrint (cladress, kwork, isize, kunit, iflag)
121C
122C* Checking
123C
124          IF (iflag .NE. 0) THEN
125              CALL prcout
126     $            ('WARNING: problem in reading mapping data',
127     $            cdgrd, 1)
128              CALL prcout
129     $            ('Could not get adress array', cladress, 1)
130              CALL prtout
131     $            ('Error reading logical unit', kunit, 1)
132              CALL prcout
133     $            ('It is connected to file', cdfic, 1)
134              CALL HALTE ('STOP in mozaic') 
135          ENDIF
136C
137C* Weights of overlapped points on source grid
138C
139          CALL locread (clweight, pwork, isize, kunit, iflag)
140C
141C* Checking
142C
143          IF (iflag .NE. 0) THEN
144              CALL prcout
145     $            ('WARNING: problem in reading mapping data',
146     $            cdgrd, 1)
147              CALL prcout
148     $            ('Could not get weight array', clweight, 1)
149              CALL prtout
150     $            ('Error reading logical unit', kunit, 1)
151              CALL prcout
152     $            ('It is connected to file', cdfic, 1)
153              CALL HALTE ('STOP in mozaic') 
154          ENDIF
155          ldread = .FALSE. 
156      ENDIF
157C
158C
159C*    3. Do the mapping interpolation
160C        ----------------------------
161C
162C* Loop on all the target grid points
163C
164      DO 310 ji = 1, ksizn
165        zsum = 0.
166        DO 320 jk = 1, knbor
167          IF (kwork(jk,ji) .NE. 0) 
168     $         zsum = zsum + pwork(jk,ji) * pfldo(kwork(jk,ji))
169 320    CONTINUE
170        pfldn(ji) = zsum
171 310  CONTINUE
172C
173C
174C*    4. End of routine
175C        --------------
176C
177      IF (nlogprt .GE. 2) THEN
178          WRITE (UNIT = nulou,FMT = *) ' '
179          WRITE (UNIT = nulou,FMT = *) 
180     $    '          --------- End of routine mozaic ---------'
181          CALL FLUSH (nulou)
182      ENDIF
183      RETURN
184      END
Note: See TracBrowser for help on using the repository browser.