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

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

O.M. : Utility to generate interpolatio weights for OASIS-MCT
File size: 6.0 KB
Line 
1! -*- Mode: f90 -*-
2!!!
3!!! Test des fichiers de poids en lecture
4!!!
5MODULE d1
6  IMPLICIT NONE
7  INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8
8  INTEGER, PARAMETER :: rl = r8, il = i4  ! Default types of all working fields
9  INTEGER, PARAMETER :: rk_in  = r8, ik_in  = i4 ! Data types in input files (masks, grids, areas)
10  INTEGER, PARAMETER :: rk_out = r8, ik_out = i4 ! Data types in output file (mozaic.w)
11  INTEGER (kind=il), PARAMETER :: nout = 6
12END MODULE d1
13!!
14MODULE com1
15  USE d1
16  IMPLICIT NONE
17  INTEGER (kind=il), PARAMETER :: jpoi = 92, jpoj = 76  ! Ocean model dimensions
18  INTEGER (kind=il), PARAMETER :: jpai = 72, jpaj = 46  ! Atmosphere model dimensions
19  INTEGER (kind=il), PARAMETER :: jpon = jpoi * jpoj, jpan = jpai * jpaj ! Global (1D) dimensions
20  INTEGER (kind=il), PARAMETER :: jpo2a = 15, jpa2o = jpai               ! Maximum number of possible neighbors
21  INTEGER (kind=il), PARAMETER :: jpanv = jpai * jpaj 
22  REAL (kind=rl)   , DIMENSION ( jpan*jpo2a) :: wo2a      ! Weights of interpolation ocean -> atmosphere
23  INTEGER (kind=il), DIMENSION ( jpan*jpo2a) :: ko2a      ! Adresses ocean -> atmosphere
24  REAL (kind=rl)   , DIMENSION ( jpon*jpa2o) :: wa2o      ! Weights of interpolation atmosphere -> ocean
25  INTEGER (kind=il), DIMENSION ( jpon*jpa2o) :: ka2o      ! Adresses atmosphere -> ocean
26END MODULE com1
27MODULE locio2
28CONTAINS
29  SUBROUTINE locread ( cdfldn, pfield, kdimax, knulre, kflgre, kout)
30    USE d1
31    IMPLICIT NONE
32    CHARACTER (LEN = 8), INTENT ( in) :: cdfldn ! Name of field to search for
33    INTEGER (kind=il), INTENT (  in) :: kdimax, knulre    ! Field dimension, unit to read
34    INTEGER (kind=il), INTENT (  in) :: kout              ! Standard output
35    INTEGER (kind=il), INTENT ( out) :: kflgre            ! Error status code
36    REAL (kind=rl)  , INTENT ( out), DIMENSION ( :) :: pfield ! Field
37    REAL (kind=rk_in), DIMENSION ( :), ALLOCATABLE :: ztemp
38    CHARACTER (len = 8) clecfl
39    INTEGER (kind=il) :: kerr
40    !
41    WRITE (UNIT = kout, FMT = '( "Locread :  Read field ", A8, " in unit = ", 1I6)' ) cdfldn, knulre
42    !
43    IF ( ALLOCATED ( ztemp)) DEALLOCATE ( ztemp)
44    ALLOCATE ( ztemp ( 1: kdimax), STAT = kerr )
45    IF ( kerr /= 0 ) THEN
46        WRITE ( kout, *) 'Error allocating itemp in locread : ', kerr
47        kflgre = kerr
48        RETURN
49    END IF
50    !
51    REWIND ( UNIT = knulre)
52200 CONTINUE
53    READ (UNIT = knulre, ERR = 200, END = 210, IOSTAT = kerr) clecfl
54    IF ( clecfl /= cdfldn ) GO TO  200
55    READ (UNIT = knulre, IOSTAT = kerr) ztemp (1:kdimax)
56    IF ( kerr == 0 ) THEN
57        pfield ( 1: kdimax) = REAL ( ztemp (1: kdimax), KIND = rl )
58    ELSE
59        WRITE ( unit = kout, fmt = *) 'Problem reading field : ', kerr
60    END IF
61    DEALLOCATE ( ztemp)
62    kflgre = kerr
63    GO TO 220
64210 kflgre = 1
65    WRITE ( unit = kout, fmt = *) 'Problem in reading'
66220 CONTINUE
67    !
68    RETURN
69  END SUBROUTINE locread
70  !
71  SUBROUTINE locrint ( cdfldn, kfield, kdimax, knulre, kflgre, kout)
72    USE d1
73    !!
74    IMPLICIT none
75    !
76    CHARACTER (LEN = 8), INTENT ( in) :: cdfldn ! Name of field to search for
77    INTEGER (kind=il), INTENT (  in) :: kdimax, knulre    ! Field dimension, unit to read
78    INTEGER (kind=il), INTENT (  in) :: kout              ! Standard output
79    INTEGER (kind=il), INTENT ( out) :: kflgre            ! Error status code
80    INTEGER (kind=il), INTENT ( inout), DIMENSION (:) :: kfield ! Field
81    INTEGER (kind=ik_in), DIMENSION ( :), ALLOCATABLE :: itemp
82    !
83    CHARACTER (len = 8) :: clecfl
84    INTEGER (kind=il) :: kerr
85    !
86    WRITE (UNIT = kout, FMT = '( "Locrint :  Read field ", A8, " in unit = ", 1I6)' ) cdfldn, knulre
87    !
88    IF ( ALLOCATED ( itemp)) DEALLOCATE ( itemp)
89    ALLOCATE ( itemp ( 1: kdimax), STAT = kerr )
90    IF ( kerr /= 0 ) THEN
91        WRITE ( kout, *) 'Error allocating itemp in locrint : ', kerr
92        kflgre = kerr
93        RETURN
94    END IF
95    !
96    REWIND ( UNIT = knulre )
97200 CONTINUE
98    !
99    READ (UNIT = knulre, ERR = 200, END = 210) clecfl
100    !
101    IF ( clecfl /= cdfldn ) GO TO  200
102    READ (UNIT = knulre, ERR = 200, END = 210, IOSTAT = kerr) itemp (1: kdimax)
103    IF ( kerr == 0 ) THEN
104        kfield (1: kdimax) = INT ( itemp (1: kdimax), KIND = il)
105    ELSE
106        WRITE ( unit = kout, fmt = *) 'Problem reading field : ', kerr
107    END IF
108    DEALLOCATE ( itemp)
109    kflgre = kerr
110    GO TO 220
111210 kflgre = 1
112    WRITE ( unit = kout, fmt = *) 'Problem in reading'
113    !
114220 CONTINUE
115    !
116    RETURN
117  END SUBROUTINE locrint
118  !!
119END MODULE locio2
120!!
121PROGRAM lecw
122  USE d1
123  USE com1
124  USE locio2
125  IMPLICIT NONE
126  INTEGER (kind=il) :: jma2o, jmo2a, nwei = 31, kerr
127  CHARACTER (len=8) :: clweight, cladress
128  !!
129  !! Lecture des poids
130  !!
131  OPEN ( unit = nwei, file = 'mozaic.w.runoff', form = 'unformatted', status = 'old', action = 'read')
132  !!
133  clweight =  "WEIGHTS1" ; cladress = "ADRESSE1" ; jmo2a = 15
134  WRITE ( unit = nout, fmt = *) cladress
135  CALL locrint ( cladress, ko2a, jpan * jmo2a , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 101
136  WRITE ( unit = nout, fmt = *) clweight
137  CALL locread ( clweight, wo2a, jpan * jmo2a , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 111
138  clweight =  "WEIGHTS2" ; cladress = "ADRESSE2" ; jma2o = 72
139  WRITE ( unit = nout, fmt = *) cladress
140  CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 102
141  WRITE ( unit = nout, fmt = *) clweight
142  CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 112
143  clweight =  "WEIGHTS3" ; cladress = "ADRESSE3" ; jma2o = 3
144  WRITE ( unit = nout, fmt = *) cladress
145  CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 103
146  WRITE ( unit = nout, fmt = *) clweight
147  CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 113
148  clweight =  "WEIGHTS4" ; cladress = "ADRESSE4" ; jma2o = 5
149  WRITE ( unit = nout, fmt = *) cladress
150  CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 104
151  WRITE ( unit = nout, fmt = *) clweight
152  CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ;  IF ( kerr /= 0 ) STOP 114
153  !!
154END PROGRAM lecw
Note: See TracBrowser for help on using the repository browser.