! -*- Mode: f90 -*- !!! !!! Test des fichiers de poids en lecture !!! MODULE d1 IMPLICIT NONE INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8 INTEGER, PARAMETER :: rl = r8, il = i4 ! Default types of all working fields INTEGER, PARAMETER :: rk_in = r8, ik_in = i4 ! Data types in input files (masks, grids, areas) INTEGER, PARAMETER :: rk_out = r8, ik_out = i4 ! Data types in output file (mozaic.w) INTEGER (kind=il), PARAMETER :: nout = 6 END MODULE d1 !! MODULE com1 USE d1 IMPLICIT NONE INTEGER (kind=il), PARAMETER :: jpoi = 92, jpoj = 76 ! Ocean model dimensions INTEGER (kind=il), PARAMETER :: jpai = 72, jpaj = 46 ! Atmosphere model dimensions INTEGER (kind=il), PARAMETER :: jpon = jpoi * jpoj, jpan = jpai * jpaj ! Global (1D) dimensions INTEGER (kind=il), PARAMETER :: jpo2a = 15, jpa2o = jpai ! Maximum number of possible neighbors INTEGER (kind=il), PARAMETER :: jpanv = jpai * jpaj REAL (kind=rl) , DIMENSION ( jpan*jpo2a) :: wo2a ! Weights of interpolation ocean -> atmosphere INTEGER (kind=il), DIMENSION ( jpan*jpo2a) :: ko2a ! Adresses ocean -> atmosphere REAL (kind=rl) , DIMENSION ( jpon*jpa2o) :: wa2o ! Weights of interpolation atmosphere -> ocean INTEGER (kind=il), DIMENSION ( jpon*jpa2o) :: ka2o ! Adresses atmosphere -> ocean END MODULE com1 MODULE locio2 CONTAINS SUBROUTINE locread ( cdfldn, pfield, kdimax, knulre, kflgre, kout) USE d1 IMPLICIT NONE CHARACTER (LEN = 8), INTENT ( in) :: cdfldn ! Name of field to search for INTEGER (kind=il), INTENT ( in) :: kdimax, knulre ! Field dimension, unit to read INTEGER (kind=il), INTENT ( in) :: kout ! Standard output INTEGER (kind=il), INTENT ( out) :: kflgre ! Error status code REAL (kind=rl) , INTENT ( out), DIMENSION ( :) :: pfield ! Field REAL (kind=rk_in), DIMENSION ( :), ALLOCATABLE :: ztemp CHARACTER (len = 8) clecfl INTEGER (kind=il) :: kerr ! WRITE (UNIT = kout, FMT = '( "Locread : Read field ", A8, " in unit = ", 1I6)' ) cdfldn, knulre ! IF ( ALLOCATED ( ztemp)) DEALLOCATE ( ztemp) ALLOCATE ( ztemp ( 1: kdimax), STAT = kerr ) IF ( kerr /= 0 ) THEN WRITE ( kout, *) 'Error allocating itemp in locread : ', kerr kflgre = kerr RETURN END IF ! REWIND ( UNIT = knulre) 200 CONTINUE READ (UNIT = knulre, ERR = 200, END = 210, IOSTAT = kerr) clecfl IF ( clecfl /= cdfldn ) GO TO 200 READ (UNIT = knulre, IOSTAT = kerr) ztemp (1:kdimax) IF ( kerr == 0 ) THEN pfield ( 1: kdimax) = REAL ( ztemp (1: kdimax), KIND = rl ) ELSE WRITE ( unit = kout, fmt = *) 'Problem reading field : ', kerr END IF DEALLOCATE ( ztemp) kflgre = kerr GO TO 220 210 kflgre = 1 WRITE ( unit = kout, fmt = *) 'Problem in reading' 220 CONTINUE ! RETURN END SUBROUTINE locread ! SUBROUTINE locrint ( cdfldn, kfield, kdimax, knulre, kflgre, kout) USE d1 !! IMPLICIT none ! CHARACTER (LEN = 8), INTENT ( in) :: cdfldn ! Name of field to search for INTEGER (kind=il), INTENT ( in) :: kdimax, knulre ! Field dimension, unit to read INTEGER (kind=il), INTENT ( in) :: kout ! Standard output INTEGER (kind=il), INTENT ( out) :: kflgre ! Error status code INTEGER (kind=il), INTENT ( inout), DIMENSION (:) :: kfield ! Field INTEGER (kind=ik_in), DIMENSION ( :), ALLOCATABLE :: itemp ! CHARACTER (len = 8) :: clecfl INTEGER (kind=il) :: kerr ! WRITE (UNIT = kout, FMT = '( "Locrint : Read field ", A8, " in unit = ", 1I6)' ) cdfldn, knulre ! IF ( ALLOCATED ( itemp)) DEALLOCATE ( itemp) ALLOCATE ( itemp ( 1: kdimax), STAT = kerr ) IF ( kerr /= 0 ) THEN WRITE ( kout, *) 'Error allocating itemp in locrint : ', kerr kflgre = kerr RETURN END IF ! REWIND ( UNIT = knulre ) 200 CONTINUE ! READ (UNIT = knulre, ERR = 200, END = 210) clecfl ! IF ( clecfl /= cdfldn ) GO TO 200 READ (UNIT = knulre, ERR = 200, END = 210, IOSTAT = kerr) itemp (1: kdimax) IF ( kerr == 0 ) THEN kfield (1: kdimax) = INT ( itemp (1: kdimax), KIND = il) ELSE WRITE ( unit = kout, fmt = *) 'Problem reading field : ', kerr END IF DEALLOCATE ( itemp) kflgre = kerr GO TO 220 210 kflgre = 1 WRITE ( unit = kout, fmt = *) 'Problem in reading' ! 220 CONTINUE ! RETURN END SUBROUTINE locrint !! END MODULE locio2 !! PROGRAM lecw USE d1 USE com1 USE locio2 IMPLICIT NONE INTEGER (kind=il) :: jma2o, jmo2a, nwei = 31, kerr CHARACTER (len=8) :: clweight, cladress !! !! Lecture des poids !! OPEN ( unit = nwei, file = 'mozaic.w.runoff', form = 'unformatted', status = 'old', action = 'read') !! clweight = "WEIGHTS1" ; cladress = "ADRESSE1" ; jmo2a = 15 WRITE ( unit = nout, fmt = *) cladress CALL locrint ( cladress, ko2a, jpan * jmo2a , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 101 WRITE ( unit = nout, fmt = *) clweight CALL locread ( clweight, wo2a, jpan * jmo2a , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 111 clweight = "WEIGHTS2" ; cladress = "ADRESSE2" ; jma2o = 72 WRITE ( unit = nout, fmt = *) cladress CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 102 WRITE ( unit = nout, fmt = *) clweight CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 112 clweight = "WEIGHTS3" ; cladress = "ADRESSE3" ; jma2o = 3 WRITE ( unit = nout, fmt = *) cladress CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 103 WRITE ( unit = nout, fmt = *) clweight CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 113 clweight = "WEIGHTS4" ; cladress = "ADRESSE4" ; jma2o = 5 WRITE ( unit = nout, fmt = *) cladress CALL locrint ( cladress, ka2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 104 WRITE ( unit = nout, fmt = *) clweight CALL locread ( clweight, wa2o, jpon * jma2o , nwei, kerr, nout) ; IF ( kerr /= 0 ) STOP 114 !! END PROGRAM lecw