[3326] | 1 | ! -*- Mode: f90 -*- |
---|
| 2 | !!! |
---|
| 3 | !!! Test des fichiers de poids en lecture |
---|
| 4 | !!! |
---|
| 5 | MODULE 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 |
---|
| 12 | END MODULE d1 |
---|
| 13 | !! |
---|
| 14 | MODULE 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 |
---|
| 26 | END MODULE com1 |
---|
| 27 | MODULE locio2 |
---|
| 28 | CONTAINS |
---|
| 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) |
---|
| 52 | 200 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 |
---|
| 64 | 210 kflgre = 1 |
---|
| 65 | WRITE ( unit = kout, fmt = *) 'Problem in reading' |
---|
| 66 | 220 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 ) |
---|
| 97 | 200 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 |
---|
| 111 | 210 kflgre = 1 |
---|
| 112 | WRITE ( unit = kout, fmt = *) 'Problem in reading' |
---|
| 113 | ! |
---|
| 114 | 220 CONTINUE |
---|
| 115 | ! |
---|
| 116 | RETURN |
---|
| 117 | END SUBROUTINE locrint |
---|
| 118 | !! |
---|
| 119 | END MODULE locio2 |
---|
| 120 | !! |
---|
| 121 | PROGRAM 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 | !! |
---|
| 154 | END PROGRAM lecw |
---|