source: CPL/oasis3/trunk/src/mod/oasis3/src/mod_intbi.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.5 KB
Line 
1      MODULE mod_intbi
2      CONTAINS
3      SUBROUTINE intbi ( pin, pax, pay, ki, kj,
4     $                   pout, px, py, kpts, ldvect)
5C****
6C               *****************************
7C               * OASIS ROUTINE  -  LEVEL 3 *
8C               * -------------     ------- *
9C               *****************************
10C
11C**** *intbi* - Interface for bicubic interpolation
12C
13C     Purpose:
14C     -------
15C     Interpolates field with bicubic scheme
16C     Source grid : global periodic grid, longitude/latitude, possibly irregular
17C     Target grid : any
18C
19C**   Interface:
20C     ---------
21C       *CALL*  *intbi* ( pin, pax, pay, ki, kj,
22C     $                  pout, px, py, kpts, ldvect)
23C
24C     Input:
25C     -----
26C                pin       : input field on source grid
27C                pax       : longitudes of source grid
28C                pay       : latitudes of source grid
29C                ki, kj    : dimension of source grid
30C                px        : longitude of target grid
31C                py        : latitudes of target grid
32C                kpts      : dimension of target grid
33C                ldvect    : flag for vector fields               
34C
35C     Output:
36C     ------
37C                poutp     : output field on target grid (real 2D)
38C
39C     Workspace:
40C     ---------
41C     Automatic arrays (sorry: not doctor)
42C               kndx, kndy : index of target point in source grid
43C               zt         : extended input field
44C               plx        : extended longitudes of source grid
45C               ply        : extended latitudes of source grid
46C     Local variables
47C               zsgn, xmin, xmax, ymin, ymax, ji, jj
48C
49C     Externals:
50C     ---------
51C     findpos, bicub
52C
53C     Reference:
54C     ---------
55C     See OASIS manual (1995)
56C
57C     History:
58C     -------
59C       Version   Programmer     Date      Description
60C       -------   ----------     ----      ----------- 
61C       2.0       O. Marti       96/07/15  Created
62C
63C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
64C
65      USE mod_findpos
66      USE mod_bicub
67CAC
68      USE mod_unit
69CAC
70C
71      IMPLICIT NONE
72C
73C* ---------------------------- Include files ---------------------------
74C
75C
76CAC      INCLUDE 'unit.h'
77C
78C* ---------------------------- Argument declarations -------------------
79C
80      INTEGER, INTENT ( in) :: ki, kj
81      REAL, DIMENSION ( ki, kj), INTENT ( in) :: pin
82      REAL, DIMENSION ( ki), INTENT ( in) :: pax 
83      REAL, DIMENSION ( kj), INTENT ( in) :: pay
84      LOGICAL, INTENT ( in) :: ldvect
85      INTEGER, INTENT ( in) :: kpts
86      REAL, DIMENSION ( kpts), INTENT ( inout) :: px, py
87      REAL, DIMENSION ( kpts), INTENT ( out) :: pout
88C
89C* ---------------------------- Local declarations ----------------------
90C
91      REAL, DIMENSION ( -1: ki + 2, -1: kj + 2) :: zt
92      REAL, DIMENSION ( -1: ki + 2) :: plx
93      REAL, DIMENSION ( -1: kj + 2) :: ply
94      INTEGER, DIMENSION ( kpts) :: kndx, kndy
95      LOGICAL :: llnorth, llsouth
96      REAL    :: zsgn, xmin, xmax, ymin, ymax
97      INTEGER :: ji, jj
98C
99C* ---------------------------- Poema verses ----------------------------
100C
101C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
102C
103C*    1. Initialization
104C        --------------
105C
106      WRITE (UNIT = nulou,FMT = *) ' '
107      WRITE (UNIT = nulou,FMT = *) ' '
108      WRITE (UNIT = nulou,FMT = *) 
109     $    '           ROUTINE intbi  -  Level 3'
110      WRITE (UNIT = nulou,FMT = *) 
111     $    '           **************     *******'
112      WRITE (UNIT = nulou,FMT = *) ' '
113      WRITE (UNIT = nulou,FMT = *) 
114     $    ' Bicubic nterpolation package '
115      WRITE (UNIT = nulou,FMT = *) ' '
116      WRITE (UNIT = nulou,FMT = *) ' '
117C
118C* Print some informations on source grid
119C
120      xmin = MINVAL ( pax) ; xmax = MAXVAL ( pax)
121      ymin = MINVAL ( pay) ; ymax = MAXVAL ( pay)
122C     
123      WRITE (UNIT = nulou,FMT = *) 
124     $    'Source grid longitude extremas : ', xmin, xmax
125      WRITE (UNIT = nulou,FMT = *) 
126     $    'Source grid latitude  extremas : ', ymin, ymax
127C
128C*    2. Interpolation
129C        -------------
130C
131C* Seek position of target points in source grid
132C
133      CALL findpos ( px, py, kpts, pax, pay, ki, kj,
134     $    kndx, kndy, plx, ply, llnorth, llsouth)
135C
136C* Extend source field
137C
138      zt ( 1:ki, 1:kj) = pin ( :, :)
139C
140C* Periodicity
141C
142      zt (    0  , 1:kj ) = pin ( ki    , 1:kj )
143      zt (   -1  , 1:kj ) = pin ( ki - 1, 1:kj )
144      zt ( ki + 1, 1:kj ) = pin (   1   , 1:kj )
145      zt ( ki + 2, 1:kj ) = pin (   2   , 1:kj )
146C
147C * Filling near poles
148C
149      zsgn = 1.0
150      IF ( ldvect ) zsgn = -1.0
151      IF ( llsouth ) THEN
152          zt ( -1: ki + 2, -1) = zsgn * zt ( -1: ki + 2,  3) 
153          zt ( -1: ki + 2,  0) = zsgn * zt ( -1: ki + 2, 2)
154      ELSE
155          zt ( -1: ki + 2, -1) = zsgn * zt ( -1: ki + 2, 2)
156          zt ( -1: ki + 2,  0) = zsgn * zt ( -1: ki + 2, 1)
157      ENDIF
158      IF ( llnorth ) THEN
159          zt ( -1: ki + 2, kj + 1) = zsgn * zt ( -1: ki + 2, kj - 1)
160          zt ( -1: ki + 2, kj + 2) = zsgn * zt ( -1: ki + 2, kj - 2)
161      ELSE
162          zt ( -1: ki + 2, kj + 1) = zsgn * zt ( -1: ki + 2, kj)
163          zt ( -1: ki + 2, kj + 2) = zsgn * zt ( -1: ki + 2, kj - 1)
164      END IF
165C
166C* Interpolates
167C
168      CALL bicub ( pout, px, py, kndx, kndy, plx, ply, kpts 
169     $    ,        zt, ki, kj)
170C
171C*    3. End of routine
172C        --------------
173      WRITE (UNIT = nulou,FMT = *) ' '
174      WRITE (UNIT = nulou,FMT = *) 
175     $    '          --------- End of routine intbi ---------'
176      CALL FLUSH (nulou)
177      RETURN
178      END SUBROUTINE intbi
179      END MODULE mod_intbi
Note: See TracBrowser for help on using the repository browser.