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

Last change on this file since 3918 was 3918, checked in by omamce, 6 years ago

O.M. : change espfrac from fortran parameter to parameter read in run.def

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