source: TOOLS/MOZAIC/src/MOZAIC/modeles.f90 @ 3326

Last change on this file since 3326 was 3326, checked in by omamce, 7 years ago

O.M. : Utility to generate interpolatio weights for OASIS-MCT
File size: 14.4 KB
Line 
1! -*- Mode: f90 -*-
2MODULE modeles
3   !> Declare tous les tableaux
4   !!
5   USE declare
6   USE dimensions
7   USE mod_prih
8   !!
9   IMPLICIT NONE
10   !!
11   SAVE
12   PUBLIC 
13   !!
14   REAL (kind=rl), PARAMETER :: eps    = EPSILON (1.0_rl) !< Standard precision epsilon
15   REAL (kind=rl), PARAMETER :: eps10  = 10.0_rl * eps    !< Standard precision epsilon * 10
16   REAL (kind=rl), PARAMETER :: epsd   = EPSILON (1.0_rd) !< Quadruple precision epsilon
17   REAL (kind=rl), PARAMETER :: epsd10 = 10.0_rd * epsd   !< Quadruple precision epsilon * 10
18   REAL (kind=rl), PARAMETER :: epsfrac = 1.0E-10_rl  !< Min fraction of sea acceptable
19   !!
20   
21   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: yas, yan, xaw, xae      !< Limits of atmos box (south, north, west, east)
22   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: yos, yon, xow, xoe      !< Limits of atmos box (south, north, west, east)
23   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolont, xolatt, xosrft  !< Lon, lat and surface at T point for ocean
24   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonu, xolatu, xosrfu  !< idem point u
25   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonv, xolatv, xosrfv  !< idem point v
26   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonf, xolatf, xosrff  !< idem point f
27   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalont, xalatt, xasrft  !< For atmosphere
28   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalonu, xalatu, xasrfu
29   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalonv, xalatv, xasrfv
30   REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xasrft_pol, xosrft_pol !< Surfaces calculées par les polygones.
31   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE  :: nborda          !< 1 if atmosphere point is over some land point of ocean grid
32   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE  :: nbordo          !< 1 if ocean point is over some land point of atmos grid
33   REAL (kind=rl)   , DIMENSION (:,:), ALLOCATABLE :: wo2a      !< Weigts of interpolation ocean -> atmosphere
34   INTEGER(kind=il) , DIMENSION (:,:), ALLOCATABLE :: ko2a      !< Adresses ocean -> atmosphere
35   REAL (kind=rl)   , DIMENSION (:,:), ALLOCATABLE :: wa2o      !< Weights of interpolation atmosphere -> ocean
36   INTEGER (kind=il), DIMENSION (:,:), ALLOCATABLE :: ka2o      ! Adresses atmosphere -> ocean
37   REAL (kind=rl)   , DIMENSION (:), ALLOCATABLE :: wasum !< Sum of weights of interpolation atmosphere -> ocean
38   REAL (kind=rl)   , DIMENSION (:), ALLOCATABLE :: wosum !< Sum of weights of interpolation ocean -> atmosphere
39   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE  :: nva   !< Number of ocean neighbor for each atm point
40   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE  :: nvo   !< Number of atmos neighbor for each ocean point
41   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iomskt, iomsku, iomskv, iomskf !< Mask ocean model (sea=0, land=1)
42   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iamskt, iamsku, iamskv                !< Mask atm model   (sea=0, land=1)
43   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iamskp        !< Mask to remove redundant point by periodicity and north folding
44   INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iomskp        !< Mask to remove redundant point by periodicity and north folding
45   REAL (kind=rl)   , DIMENSION (:, :), ALLOCATABLE  :: xo_ed !< Longitude of corner of oce boxes
46   !< UL,UM,UR,MR,LR,LM,LL,ML.9 for middle of box
47   REAL (kind=rl)   , DIMENSION (:, :), ALLOCATABLE :: yo_ed !< Lat
48   REAL (kind=rl)   , DIMENSION (:, :), ALLOCATABLE :: xa_ed !< Atm
49   REAL (kind=rl)   , DIMENSION (:, :), ALLOCATABLE :: ya_ed
50   !!
51   CHARACTER (LEN=4) :: comod_a, comod_t, comod_u, comod_v, comod_f
52   CHARACTER (LEN=4) :: camod_a, camod_t, camod_u, camod_v, camod_f
53   !!
54   INTEGER (kind=il) :: maxo, maxa                         !
55   INTEGER (kind=il) :: nsum     !< Ponderation suivant le type de point trouve
56   !!
57   REAL (kind=rl) :: xinf, xsup                            !< Longitudes minimales et maximales de travail
58   INTEGER (kind=il) :: ngrd, nsrf, nmsk, nwei4o2a, nwei4a2o, nwei8o2a, nwei8a2o, nchk, ndeb, nbug1, nwei8, nwei4  !< IO unit numbers
59   !!
60   REAL (kind=rl) :: ra = 6371229.0_rl               !< Earth Radius (for OPA)
61   REAL (kind=rl) :: xsurfa, xsurfo                  !< Earth surface in each model
62   !!
63   CHARACTER (LEN = 8) :: cladress, clweight !< Name of OASIS weights/adresses
64
65   !
66   REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: o2amask !< Ocean mask interpolated toward atmosphere
67   REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: a2omask !< Atmosphere mask interpolated toward ocean
68   REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: o2afull !< 1 on ocean interpolated toward atmosphere
69   REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: a2ofull !< 1 on atmosphere interpolated toward ocean
70   !
71   INTEGER, DIMENSION (:), ALLOCATABLE :: o2amask_i_int !< Ocean mask interpolated toward atmosphere : full land only
72   INTEGER, DIMENSION (:), ALLOCATABLE :: o2amask_i_ext !< Ocean mask interpolated toward atmosphere : all points with some land
73   INTEGER, DIMENSION (:), ALLOCATABLE :: a2omask_i_int !< Atmosphere mask interpolated toward ocean : full land only
74   INTEGER, DIMENSION (:), ALLOCATABLE :: a2omask_i_ext !< Atmosphere mask interpolated toward ocean : all points with some land
75   !!
76   INTEGER (kind = il), DIMENSION (:), ALLOCATABLE :: m2ai, m2aj, m2oi, m2oj, moi, moj, mai, maj
77   INTEGER (kind = il), DIMENSION (:, :), ALLOCATABLE :: m1a, m1ar, m1o, m1or
78   !!
79CONTAINS
80   !!
81   SUBROUTINE alloc_modeles
82      !> Dimensionne tout les tableaux necessaires
83      IMPLICIT NONE
84      !!
85      INTEGER (kind=il) :: ja, jo, jai, jaj, joi, joj
86      INTEGER :: ierr
87      !!
88      WRITE (nout, *) 'Data types '
89      WRITE (nout, *) 'r_4 : ', r_4, 1.0_r_4, TINY(1.0_r_4), HUGE(1.0_r_4), EPSILON (1.0_r_4)
90      WRITE (nout, *) 'r_8 : ', r_8, 1.0_r_8, TINY(1.0_r_8), HUGE(1.0_r_8), EPSILON (1.0_r_8)
91      WRITE (nout, *) 'rd  : ', rd , 1.0_rd , TINY(1.0_rd) , HUGE(1.0_rd) , EPSILON (1.0_rd)
92      WRITE (nout, *) 'rl  : ', rl , 1.0_rl , TINY(1.0_rl) , HUGE(1.0_rl) , EPSILON (1.0_rl)
93      !!
94      ALLOCATE (yas    (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'yas', lreset = .TRUE., crout = 'common')
95      ALLOCATE (yan    (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'yan')
96      ALLOCATE (xaw    (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xaw')
97      ALLOCATE (xae    (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xae')
98
99      ALLOCATE (yos    (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'yos')
100      ALLOCATE (yon    (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'yon')
101      ALLOCATE (xow    (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xow')
102      ALLOCATE (xoe    (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xoe')
103      !
104      ALLOCATE (xolont (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolont')
105      ALLOCATE (xolonu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonu')
106      ALLOCATE (xolonv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonv')
107      ALLOCATE (xolonf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonf')
108      ALLOCATE (xolatt (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatt')
109      ALLOCATE (xolatu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatu')
110      ALLOCATE (xolatv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatv')
111      ALLOCATE (xolatf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatf')
112      ALLOCATE (xosrft (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrft')
113      ALLOCATE (xosrfu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrfu')
114      ALLOCATE (xosrfv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrfv')
115      ALLOCATE (xosrff (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrff')
116      !
117      ALLOCATE (xosrft_pol (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrft_pol')
118      ALLOCATE (xasrft_pol (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrft_pol')
119      !
120      ALLOCATE (xalont (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalont')
121      ALLOCATE (xalonu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalonu')
122      ALLOCATE (xalonv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xalonv')
123      ALLOCATE (xalatt (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalatt')
124      ALLOCATE (xalatu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalatu')
125      ALLOCATE (xalatv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xalatv')
126      ALLOCATE (xasrft (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrft')
127      ALLOCATE (xasrfu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrfu')
128      ALLOCATE (xasrfv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xasrfv')
129      !
130      ALLOCATE (nborda (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'nborda')
131      ALLOCATE (nbordo (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'nbordo')
132      !
133      ALLOCATE (wo2a (jpo2a,jpan), STAT=ierr) ; CALL chk_allo (ierr, 'wo2a')
134      ALLOCATE (ko2a (jpo2a,jpan), STAT=ierr) ; CALL chk_allo (ierr, 'ko2a')
135      ALLOCATE (wa2o (jpa2o,jpon), STAT=ierr) ; CALL chk_allo (ierr, 'wa2o')
136      ALLOCATE (ka2o (jpa2o,jpon), STAT=ierr) ; CALL chk_allo (ierr, 'ka2o')
137
138      ALLOCATE (wasum (jpan)     , STAT=ierr) ; CALL chk_allo (ierr, 'wasum')
139      ALLOCATE (wosum (jpon)     , STAT=ierr) ; CALL chk_allo (ierr, 'wosum')
140      !
141      ALLOCATE (nvo (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'nvo')
142      ALLOCATE (nva (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'nva')
143      !
144      ALLOCATE (iomskt (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskt')
145      ALLOCATE (iomsku (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomsku')
146      ALLOCATE (iomskv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskv')
147      ALLOCATE (iomskf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskf')
148      ALLOCATE (iamskt (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamskt')
149      ALLOCATE (iamsku (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamsku')
150      ALLOCATE (iamskv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'iamskv')
151      ALLOCATE (iomskp (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskp')
152      ALLOCATE (iamskp (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamskp')
153      !
154      ALLOCATE (xo_ed (jpon, jpoe), STAT=ierr) ; CALL chk_allo (ierr, 'xo_ed')
155      ALLOCATE (yo_ed (jpon, jpoe), STAT=ierr) ; CALL chk_allo (ierr, 'yo_ed')
156      ALLOCATE (xa_ed (jpan, jpae), STAT=ierr) ; CALL chk_allo (ierr, 'xa_ed')
157      ALLOCATE (ya_ed (jpan, jpae), STAT=ierr) ; CALL chk_allo (ierr, 'ya_ed')
158      !
159      ALLOCATE (o2amask (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask')
160      ALLOCATE (a2omask (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask')
161      ALLOCATE (o2afull (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2afull')
162      ALLOCATE (a2ofull (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2ofull')
163      ALLOCATE (o2amask_i_int (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask_i_int')
164      ALLOCATE (o2amask_i_ext (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask_i_ext')
165      ALLOCATE (a2omask_i_int (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask_i_int')
166      ALLOCATE (a2omask_i_ext (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask_i_ext')
167      !
168      ! ----------------------------------------------------------------------------
169      ALLOCATE (m2ai (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'm2ai')
170      ALLOCATE (m2aj (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'm2aj')
171      ALLOCATE (mai  (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'mai ')
172      ALLOCATE (maj  (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'maj ')
173      m2ai (0) = 0_il ; m2aj (0) = 0_il
174      DO ja = 1, jpan
175         jai = MOD (ja - 1_il, jpai) + 1_il
176         jaj = (ja - 1_il) / jpai + 1_il
177         m2ai (ja) = jai
178         m2aj (ja) = jaj
179         mai  (ja) = jai
180         maj  (ja) = MAX (1_il, MIN (jaj, jpaj))
181         IF (la_pole) THEN
182            IF (jai ==  -1_il   ) mai (ja) = jpai-1_il
183            IF (jai ==   0_il   ) mai (ja) = jpai
184            IF (jai == jpai+1_il) mai (ja) = 1_il
185            IF (jai == jpai+2_il) mai (ja) = 2_il
186         END IF
187      END DO
188      ! ----------------------------------------------------------------------------
189      ALLOCATE (m2oi (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'm2oi')
190      ALLOCATE (m2oj (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'm2oj')
191      ALLOCATE (moi  (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'moi ')
192      ALLOCATE (moj  (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'moj ')
193      m2oi (0) = 0_il ; m2oj (0) = 0_il
194      moi  (0) = 0_il ; moj  (0) = 0_il
195      DO jo = 1, jpon
196         joi = MOD (jo - 1_il, jpoi) + 1_il
197         joj = (jo - 1_il) / jpoi + 1_il
198         m2oi (jo) = joi
199         m2oj (jo) = joj
200         moi  (jo) = joi
201         moj  (jo) = MAX (1_il, MIN (joj, jpoj))
202         IF (noperio == 1 .OR. noperio == 4 .OR. noperio == -4_il) THEN
203            IF (joi ==  -1_il   ) moi (jo) = jpoi-3_il
204            IF (joi ==   0_il   ) moi (jo) = jpoi-2_il
205            IF (joi ==   1_il   ) moi (jo) = jpoi-1_il
206            IF (joi == jpoi     ) moi (jo) = 2_il
207            IF (joi == jpoi+1_il) moi (jo) = 3_il
208            IF (joi == jpoi+2_il) moi (jo) = 4_il
209         ENDIF
210      END DO
211      ! ----------------------------------------------------------------------------
212      ALLOCATE (m1a  (jpai, jpaj), STAT=ierr) ; CALL chk_allo (ierr, 'm1a ')
213      ALLOCATE (m1ar (jpai, jpaj), STAT=ierr) ; CALL chk_allo (ierr, 'm1ar')
214      DO jaj = 1, jpaj
215         DO jai = 1, jpai
216            m1a (jai, jaj) = jai + (jaj - 1_il) * jpai
217         END DO
218      END DO
219      DO jaj = 1, jpaj
220         DO jai = 1, jpai
221            ja = m1a (jai, jaj)
222            m1a (jai, jaj) = m1a (mai (ja), maj (ja))
223         END DO
224      END DO
225      ! ----------------------------------------------------------------------------
226      ALLOCATE (m1o  (jpoi, jpoj), STAT=ierr) ; CALL chk_allo (ierr, 'm1o ')
227      ALLOCATE (m1or (jpoi, jpoj), STAT=ierr) ; CALL chk_allo (ierr, 'm1or')
228      DO joj = 1, jpoj
229         DO joi = 1, jpoi
230            m1o  (joi, joj) = joi + (joj - 1_il) * jpoi
231         END DO
232      END DO
233      DO joj = 1, jpoj
234         DO joi = 1, jpoi
235            jo = m1o (joi, joj)
236            m1or (joi, joj) = m1o (moi (jo), moj (jo))
237         END DO
238      END DO
239      ! ----------------------------------------------------------------------------
240     
241!-$$      WRITE (nout,*) 'mai'
242!-$$      CALL prihin ( RESHAPE(mai (1:jpan), (/jpai, jpaj/)), kscale=3 )
243!-$$      WRITE (nout,*) 'maj'
244!-$$      CALL prihin ( RESHAPE(maj (1:jpan), (/jpai, jpaj/)), kscale=3 )
245!-$$      WRITE (nout,*) 'm2ai'
246!-$$      CALL prihin ( RESHAPE(m2ai(1:jpan), (/jpai, jpaj/)), kscale=3 )
247!-$$      WRITE (nout,*) 'm2aj'
248!-$$      CALL prihin ( RESHAPE(m2aj(1:jpan), (/jpai, jpaj/)), kscale=3 )
249!-$$      WRITE (nout,*) 'm1a'
250!-$$      CALL prihin (m1a , kscale=5)
251!-$$      WRITE (nout,*) 'm1ar'
252!-$$      CALL prihin (m1ar, kscale=5)
253!-$$      STOP
254
255   END SUBROUTINE alloc_modeles
256END MODULE modeles
Note: See TracBrowser for help on using the repository browser.