WPS/util/src/mod_levs.F90

   1 !  Program to modify levels in the intermediate format.  Two input
   2 !  files come in on the command line: input file and output file.
   3 !  An additional namelist file is used to select which pressure levels
   4 !  are to be kept.
   5
   6 !  NRCM helper, WPS toy code
   7
   8 PROGRAM mod_levs_prog
   9
  10    USE module_debug
  11    USE read_met_module
  12    USE write_met_module
  13    USE misc_definitions_module
  14
  15    IMPLICIT NONE
  16
  17    !  Intermediate input and output from same source.
  18
  19    CHARACTER ( LEN =132 )            :: flnm, flnm2
  20
  21    INTEGER :: istatus, iop
  22    integer :: idum, ilev
  23
  24    TYPE (met_data)                   :: fg_data
  25
  26    !  The namelist has a pressure array that we want.
  27
  28    LOGICAL                           :: keep_this_one
  29    INTEGER                           :: l , max_pres_keep
  30    INTEGER , PARAMETER               :: num_pres_lev = 1000
  31    REAL, DIMENSION(num_pres_lev)     :: press_pa = -1.
  32    NAMELIST /mod_levs/ press_pa
  33
  34    INTEGER , EXTERNAL :: lenner
  35
  36    !  Open up the file with the pressure levels to process.
  37
  38    OPEN ( UNIT   =  10            , &
  39           FILE   = 'namelist.wps' , &
  40           STATUS = 'OLD'          , &
  41           FORM   = 'FORMATTED'    , &
  42           IOSTAT =  iop              )
  43
  44    IF (iop .NE. 0) then
  45       print *, 'Problem with namelist.input file, I can''t open it'
  46       STOP
  47    END IF
  48
  49    !  Input the pressure levels requested.
  50
  51    READ ( 10 , mod_levs )
  52
  53    CLOSE ( 10 )
  54
  55    !  How many pressure levels were asked for?
  56
  57    DO l = 1 , num_pres_lev
  58       IF ( press_pa(l) .EQ. -1. ) THEN
  59          max_pres_keep = l-1
  60          EXIT
  61       END IF
  62    END DO
  63
  64    !  Get the two files: input and output.
  65
  66    CALL getarg ( 1 , flnm  )
  67
  68    IF ( flnm(1:1) .EQ. ' ' ) THEN
  69       print *,'USAGE: mod_levs.exe FILE:2006-07-31_00 new_FILE:2006-07-31_00'
  70       STOP
  71    END IF
  72
  73    CALL getarg ( 2 , flnm2 )
  74
  75    l = lenner(flnm)
  76    IF ( flnm2(1:1) .EQ. ' ' ) THEN
  77       flnm2(5:l+4) = flnm(1:l)
  78       flnm2(1:4) = 'new_'
  79    END IF
  80
  81    CALL set_debug_level(WARN)
  82
  83    CALL read_met_init(TRIM(flnm), .true., '0000-00-00_00', istatus)
  84
  85    IF ( istatus == 0 ) THEN
  86
  87       CALL write_met_init(TRIM(flnm2), .true., '0000-00-00_00', istatus)
  88
  89       IF ( istatus == 0 ) THEN
  90
  91          CALL read_next_met_field(fg_data, istatus)
  92
  93          DO WHILE (istatus == 0)
  94
  95
  96             keep_this_one = .FALSE.
  97             DO l = 1 , max_pres_keep
  98                IF ( fg_data%xlvl .EQ. press_pa(l) ) THEN
  99                   keep_this_one = .TRUE.
 100                   EXIT
 101                END IF
 102             END DO
 103
 104             IF (keep_this_one) THEN
 105                CALL write_next_met_field(fg_data, istatus)
 106             ELSE
 107                CALL mprintf(.true.,STDOUT,'Deleting level %f Pa',f1=fg_data%xlvl)
 108             END IF
 109
 110             CALL mprintf(.true.,STDOUT,'Processed %s at level %f for time %s', &
 111                          s1=fg_data%field, f1=fg_data%xlvl, s2=fg_data%hdate)
 112             IF (ASSOCIATED(fg_data%slab)) DEALLOCATE(fg_data%slab)
 113
 114             CALL read_next_met_field(fg_data, istatus)
 115          END DO
 116
 117          CALL write_met_close()
 118
 119       ELSE
 120
 121          print *, 'File = ',TRIM(flnm2)
 122          print *, 'Problem with output file, I can''t open it'
 123          STOP
 124
 125       END IF
 126
 127       CALL read_met_close()
 128
 129    ELSE
 130
 131       print *, 'File = ',TRIM(flnm)
 132       print *, 'Problem with input file, I can''t open it'
 133       STOP
 134
 135    END IF
 136
 137    print *,'SUCCESSFUL COMPLETION OF PROGRAM MOD_LEVS'
 138    STOP
 139
 140 END PROGRAM mod_levs_prog
 141
 142 INTEGER FUNCTION lenner ( string )
 143    CHARACTER ( LEN = 132 ) ::  string
 144    INTEGER :: l
 145    DO l = 132 , 1 , -1
 146       IF ( ( ( string(l:l) .GE. 'A' ) .AND. ( string(l:l) .LE. 'Z' ) ) .OR. &
 147            ( ( string(l:l) .GE. 'a' ) .AND. ( string(l:l) .LE. 'z' ) ) .OR. &
 148            ( ( string(l:l) .GE. '0' ) .AND. ( string(l:l) .LE. '9' ) ) ) THEN
 149          lenner = l
 150          EXIT
 151       END IF
 152    END DO
 153 END FUNCTION lenner