MODULE diaobs !!====================================================================== !! *** MODULE diaobs *** !! Observation diagnostics: Computation of the misfit between data and !! their model equivalent !!====================================================================== !!---------------------------------------------------------------------- !! 'key_diaobs' : Switch on the observation diagnostic computation !!---------------------------------------------------------------------- !! dia_obs_init : Reading and prepare observations !! dia_obs : Compute model equivalent to observations !! dia_obs_wri : Write observational diagnostics !! ini_date : Compute the initial date YYYYMMDD.HHMMSS !! fin_date : Compute the final date YYYYMMDD.HHMMSS !!---------------------------------------------------------------------- !! * Modules used USE wrk_nemo ! Memory Allocation USE par_kind ! Precision variables USE in_out_manager ! I/O manager USE par_oce USE dom_oce ! Ocean space and time domain variables USE obs_fbm, ONLY: ln_cl4 ! Class 4 diagnostic switch USE obs_read_prof ! Reading and allocation of observations (Coriolis) USE obs_read_surf ! Reading and allocation of SLA observations USE obs_readmdt ! Reading and allocation of MDT for SLA. USE obs_prep ! Preparation of obs. (grid search etc). USE obs_oper ! Observation operators USE obs_write ! Writing of observation related diagnostics USE obs_grid ! Grid searching USE obs_read_altbias ! Bias treatment for altimeter USE obs_profiles_def ! Profile data definitions USE obs_surf_def ! Surface data definitions USE obs_types ! Definitions for observation types USE mpp_map ! MPP mapping USE lib_mpp ! For ctl_warn/stop IMPLICIT NONE !! * Routine accessibility PRIVATE PUBLIC dia_obs_init, & ! Initialize and read observations & dia_obs, & ! Compute model equivalent to observations & dia_obs_wri, & ! Write model equivalent to observations & dia_obs_dealloc ! Deallocate dia_obs data !! * Shared Module variables LOGICAL, PUBLIC, PARAMETER :: & #if defined key_diaobs & lk_diaobs = .TRUE. !: Logical switch for observation diangostics #else & lk_diaobs = .FALSE. !: Logical switch for observation diangostics #endif !! * Module variables LOGICAL, PUBLIC :: ln_t3d !: Logical switch for temperature profiles LOGICAL, PUBLIC :: ln_s3d !: Logical switch for salinity profiles LOGICAL, PUBLIC :: ln_sla !: Logical switch for sea level anomalies LOGICAL, PUBLIC :: ln_sst !: Logical switch for sea surface temperature LOGICAL, PUBLIC :: ln_seaice !: Logical switch for sea ice concentration LOGICAL, PUBLIC :: ln_vel3d !: Logical switch for velocity component (u,v) observations LOGICAL, PUBLIC :: ln_ssh !: Logical switch for sea surface height LOGICAL, PUBLIC :: ln_sss !: Logical switch for sea surface salinity LOGICAL, PUBLIC :: ln_sstnight !: Logical switch for night mean SST observations LOGICAL, PUBLIC :: ln_nea !: Remove observations near land LOGICAL, PUBLIC :: ln_altbias !: Logical switch for altimeter bias LOGICAL, PUBLIC :: ln_ignmis !: Logical switch for ignoring missing files LOGICAL, PUBLIC :: ln_s_at_t !: Logical switch to compute model S at T observations REAL(KIND=dp), PUBLIC :: dobsini !: Observation window start date YYYYMMDD.HHMMSS REAL(KIND=dp), PUBLIC :: dobsend !: Observation window end date YYYYMMDD.HHMMSS INTEGER, PUBLIC :: numobtypes !: Number of observation types to read in. INTEGER, PUBLIC :: n1dint !: Vertical interpolation method INTEGER, PUBLIC :: n2dint !: Horizontal interpolation method INTEGER, DIMENSION(:), ALLOCATABLE :: nvarsprof !Number of profile variables INTEGER, DIMENSION(:), ALLOCATABLE :: nextrprof !Number of profile extra variables INTEGER, DIMENSION(:), ALLOCATABLE :: nvarssurf !Number of surface variables INTEGER, DIMENSION(:), ALLOCATABLE :: nextrsurf !Number of surface extra variables INTEGER, DIMENSION(imaxavtypes) :: & & dailyavtypes !: Data types which are daily average TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata ! Initial surface data TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc ! Surface data after quality control TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata ! Initial profile data TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc ! Profile data after quality control CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: obstypesprof CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: obstypessurf INTEGER, PARAMETER :: MaxNumFiles = 1000 LOGICAL, DIMENSION(MaxNumFiles) :: & & ln_profb_ena, & !: Is the feedback files from ENACT data ? ! !: If so use dailyavtypes & ln_profb_enatim !: Change tim for 820 enact data set. LOGICAL, DIMENSION(MaxNumFiles) :: & & ln_velfb_av !: Is the velocity feedback files daily average? LOGICAL, DIMENSION(:), ALLOCATABLE :: & & ld_enact !: Profile data is ENACT so use dailyavtypes LOGICAL, DIMENSION(:), ALLOCATABLE :: & & ld_velav !: Velocity data is daily averaged LOGICAL, DIMENSION(:), ALLOCATABLE :: & & ld_sstnight !: SST observation corresponds to night mean !!---------------------------------------------------------------------- !! NEMO/OPA 3.3 , NEMO Consortium (2010) !! $Id$ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) !!---------------------------------------------------------------------- CONTAINS SUBROUTINE dia_obs_init !!---------------------------------------------------------------------- !! *** ROUTINE dia_obs_init *** !! !! ** Purpose : Initialize and read observations !! !! ** Method : Read the namelist and call reading routines !! !! ** Action : Read the namelist and call reading routines !! !! History : !! ! 06-03 (K. Mogensen) Original code !! ! 06-05 (A. Weaver) Reformatted !! ! 06-10 (A. Weaver) Cleaning and add controls !! ! 07-03 (K. Mogensen) General handling of profiles !! ! 15-02 (M. Martin) Simplification of namelist and code !!---------------------------------------------------------------------- IMPLICIT NONE !! * Local declarations CHARACTER(len=128) :: profbfiles(MaxNumFiles) CHARACTER(len=128) :: sstfbfiles(MaxNumFiles) CHARACTER(len=128) :: slafbfiles(MaxNumFiles) CHARACTER(len=128) :: seaicefbfiles(MaxNumFiles) CHARACTER(len=128) :: velfbfiles(MaxNumFiles) CHARACTER(LEN=128) :: bias_file CHARACTER(LEN=20) :: datestr=" ", timestr=" " NAMELIST/namobs/ln_t3d, ln_s3d, ln_sla, ln_sss, ln_ssh, & & ln_sst, ln_seaice, ln_vel3d, & & ln_altbias, ln_nea, ln_grid_global, & & ln_grid_search_lookup, ln_cl4, & & ln_ignmis, ln_s_at_t, ln_sstnight, & & ln_profb_ena, ln_profb_enatim, & & profbfiles, slafbfiles, sssfbfiles, & & sshfbfiles, sstfbfiles, seaicefbfiles, & & velfbfiles, bias_file, grid_search_file, & & dobsini, dobsend, n1dint, n2dint, & & nmsshc, mdtcorr, mdtcutoff, & & grid_search_res, dailyavtypes INTEGER :: jtype INTEGER :: ios ! Local integer output status for namelist read INTEGER, DIMENSION(:), ALLOCATABLE :: jnumfilesprof INTEGER, DIMENSION(:), ALLOCATABLE :: jnumfilessurf CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: obsfilesprof CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: obsfilessurf LOGICAL :: lmask(MaxNumFiles) !----------------------------------------------------------------------- ! Read namelist parameters !----------------------------------------------------------------------- profbfiles(:) = '' slafbfiles(:) = '' sstfbfiles(:) = '' seaicefbfiles(:) = '' velfbfiles(:) = '' dailyavtypes(:) = -1 dailyavtypes(1) = 820 ln_profb_ena(:) = .FALSE. ln_profb_enatim(:) = .TRUE. ln_velfb_av(:) = .FALSE. ln_ignmis = .FALSE. CALL ini_date( dobsini ) CALL fin_date( dobsend ) ! Read Namelist namobs : control observation diagnostics REWIND( numnam_ref ) ! Namelist namobs in reference namelist : Diagnostic: control observation READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist : Diagnostic: control observation READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) IF(lwm) WRITE ( numond, namobs ) !Set up list of observation types to be used numproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) numsurftypes = COUNT( (/ln_sla, ln_sss, ln_sst, ln_seaice /) ) IF ( numproftypes > 0 ) THEN ALLOCATE( obstypesprof(numproftypes) ) ALLOCATE( jnumfilesprof(numproftypes) ) ALLOCATE( obsfilesprof(numproftypes, MaxNumFiles) ) DO jtype = 1, numproftypes IF (ln_t3d .OR. ln_s3d) THEN obsfilesprof(:,jtype) = profbfiles(:) obstypesprof(jtype) = 'prof' ENDIF IF (ln_vel3d) THEN obsfilesprof(:,jtype) = velfbfiles(:) obstypesprof(jtype) = 'vel' ENDIF lmask(:) = .FALSE. WHERE (obsfilesprof(jtype,:) /= '') lmask(:) = .TRUE. jnumfilesprof(jtype) = COUNT(lmask) END DO ENDIF IF ( numsurftypes > 0 ) THEN ALLOCATE( obstypessurf(numsurftypes) ) ALLOCATE( jnumfilessurf(numproftypes) ) ALLOCATE( obsfilessurf(numsurftypes, MaxNumFiles) ) DO jtype = 1, numsurftypes IF (ln_sla) THEN obsfilessurf(:,jtype) = slafbfiles(:) obstypessurf(jtype) = 'sla' ENDIF IF (ln_sss) THEN obsfilessurf(:,jtype) = sssfbfiles(:) obstypessurf(jtype) = 'sss' ENDIF IF (ln_sst) THEN obsfilessurf(:,jtype) = sstfbfiles(:) obstypessurf(jtype) = 'sst' ENDIF #if defined key_lim2 || defined key_lim3 IF (ln_seaice) THEN obsfilessurf(:,jtype) = seaicefbfiles(:) obstypessurf(jtype) = 'seaice' ENDIF #endif lmask(:) = .FALSE. WHERE (obsfilessurf(jtype,:) /= '') lmask(:) = .TRUE. jnumfilessurf(jtype) = COUNT(lmask) END DO ENDIF !Write namelist settings to stdout IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization' WRITE(numout,*) '~~~~~~~~~~~~' WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla WRITE(numout,*) ' Logical switch for SSH observations ln_ssh = ', ln_ssh WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss WRITE(numout,*) ' Logical switch for Sea Ice observations ln_seaice = ', ln_seaice WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d WRITE(numout,*) ' Global distribution of observations ln_grid_global = ',ln_grid_global WRITE(numout,*) & ' Logical switch for obs grid search w/lookup table ln_grid_search_lookup = ',ln_grid_search_lookup IF (ln_grid_search_lookup) & WRITE(numout,*) ' Grid search lookup file header grid_search_file = ', grid_search_file WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS dobsini = ', dobsin WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS dobsend = ', dobsend WRITE(numout,*) ' Type of vertical interpolation method n1dint = ', n1dint WRITE(numout,*) ' Type of horizontal interpolation method n2dint = ', n2dint WRITE(numout,*) ' Rejection of observations near land swithch ln_nea = ', ln_nea WRITE(numout,*) ' MSSH correction scheme nmsshc = ', nmsshc WRITE(numout,*) ' MDT correction mdtcorr = ', mdtcorr WRITE(numout,*) ' MDT cutoff for computed correction mdtcutoff = ', mdtcutoff WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis WRITE(numout,*) ' Daily average types = ', dailyavtypes IF ( numproftypes > 0 ) THEN DO jtype = 1, numproftypes DO ji = 1, jnumfilesprof(jtype) WRITE(numout,'(1X,2A)') ' '//obstypesprof(jtype)//' input observation file names = ', & TRIM(obsfilesprof(jtype,ji)) IF ( TRIM(obstypesprof(jtype)) == 'prof' ) & WRITE(numout,'(1X,2A)') ' Enact feedback input time setting switch ln_profb_enatim = ', ln_profb_enatim(ji) END DO END DO ENDIF IF ( numsurftypes > 0 ) THEN DO jtype = 1, numsurftypes DO ji = 1, jnumfilessurf(jtype) WRITE(numout,'(1X,2A)') ' '//obstypessurf(jtype)//' input observation file names = ', & TRIM(obsfilessurf(jtype,ji)) END DO END DO ENDIF ENDIF IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) RETURN ENDIF CALL obs_typ_init CALL mppmap_init ! Parameter control #if defined key_diaobs IF ( numobtypes == 0 ) THEN IF(lwp) WRITE(numout,cform_war) IF(lwp) WRITE(numout,*) ' key_diaobs is activated but logical flags', & & ' ln_t3d, ln_s3d, ln_sla, ln_ssh, ln_sst, ln_sss, ln_seaice, ln_vel3d are all set to .FALSE.' nwarn = nwarn + 1 ENDIF #endif CALL obs_grid_setup( ) IF ( ( n1dint < 0 ).OR.( n1dint > 1 ) ) THEN CALL ctl_stop(' Choice of vertical (1D) interpolation method', & & ' is not available') ENDIF IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & & ' is not available') ENDIF !----------------------------------------------------------------------- ! Depending on switches read the various observation types !----------------------------------------------------------------------- IF ( numproftypes > 0 ) THEN ALLOCATE(profdata(numproftypes)) ALLOCATE(profdataqc(numproftypes)) ALLOCATE(nvarsprof(numproftypes)) ALLOCATE(nextrprof(numproftypes)) DO jtype = 1, numproftypes nvarsprof(jtype) = 2 IF ( TRIM(obstypesprof(jtype)) == 'prof' ) nextrprof(jtype) = 1 IF ( TRIM(obstypesprof(jtype)) == 'vel' ) nextrprof(jtype) = 2 !Read in profile or velocity obs types CALL obs_rea_prof( profdata(jtype), & & jnumfilesprof(jtype), & & obsfilesprof(jtype,1:jnumfilesprof(jtype)), & & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & & dobsini, dobsend, ln_t3d, ln_s3d, & & ln_ignmis, ln_s_at_t, .TRUE., .FALSE., & & kdailyavtypes = dailyavtypes ) DO jvar = 1, nvars CALL obs_prof_staend( profdata(jtype), jvar ) END DO CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & & ln_t3d, ln_s3d, ln_nea, & & kdailyavtypes = dailyavtypes ) END DO DEALLOCATE( jnumfilesprof, obsfilesprof ) ENDIF IF ( numsurftypes > 0 ) THEN ALLOCATE(surfdata(numsurftypes)) ALLOCATE(surfdatatqc(numsurftypes)) ALLOCATE(nvarssurf(numsurftypes)) ALLOCATE(nextrsurf(numsurftypes)) DO jtype = 1, numsurftypes nvarssurf(jtype) = 1 nextrsurf(jtype) = 0 IF ( TRIM(obstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 !Read in surface obs types CALL obs_rea_surf( surfdata(jtype), jnumfilessurf(jtype), & & obsfilessurf(jtype,1:jnumfilessurf(jtype)), & & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & & dobsini, dobsend, ln_ignmis, .FALSE. ) CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea ) IF ( TRIM(obstypessurf(jtype)) == 'sla' ) THEN CALL obs_rea_mdt( surfdataqc(jtype), n2dint ) IF ( ln_altbias ) CALL obs_rea_altbias ( surfdataqc(jtype), n2dint, bias_file ) ENDIF DEALLOCATE( jnumfilessurf, obsfilessurf ) END DO END SUBROUTINE dia_obs_init SUBROUTINE dia_obs( kstp ) !!---------------------------------------------------------------------- !! *** ROUTINE dia_obs *** !! !! ** Purpose : Call the observation operators on each time step !! !! ** Method : Call the observation operators on each time step to !! compute the model equivalent of the following date: !! - T profiles !! - S profiles !! - Sea surface height (referenced to a mean) !! - Sea surface temperature !! - Sea surface salinity !! - Velocity component (U,V) profiles !! !! ** Action : !! !! History : !! ! 06-03 (K. Mogensen) Original code !! ! 06-05 (K. Mogensen) Reformatted !! ! 06-10 (A. Weaver) Cleaning !! ! 07-03 (K. Mogensen) General handling of profiles !! ! 07-04 (G. Smith) Generalized surface operators !! ! 08-10 (M. Valdivieso) obs operator for velocity profiles !!---------------------------------------------------------------------- !! * Modules used USE dom_oce, ONLY : & ! Ocean space and time domain variables & rdt, & & gdept_1d, & & tmask, umask, vmask USE phycst, ONLY : & ! Physical constants & rday USE oce, ONLY : & ! Ocean dynamics and tracers variables & tsn, & & un, vn, & & sshn #if defined key_lim3 USE ice, ONLY : & ! LIM Ice model variables & frld #endif #if defined key_lim2 USE ice_2, ONLY : & ! LIM Ice model variables & frld #endif IMPLICIT NONE !! * Arguments INTEGER, INTENT(IN) :: kstp ! Current timestep !! * Local declarations INTEGER :: idaystp ! Number of timesteps per day INTEGER :: jtype ! data loop variable INTEGER :: jvar ! Variable number #if ! defined key_lim2 && ! defined key_lim3 REAL(wp), POINTER, DIMENSION(:,:) :: frld #endif CHARACTER(LEN=20) :: datestr=" ",timestr=" " #if ! defined key_lim2 && ! defined key_lim3 CALL wrk_alloc(jpi,jpj,frld) #endif IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) 'dia_obs : Call the observation operators', kstp WRITE(numout,*) '~~~~~~~' ENDIF idaystp = NINT( rday / rdt ) !----------------------------------------------------------------------- ! No LIM => frld == 0.0_wp !----------------------------------------------------------------------- #if ! defined key_lim2 && ! defined key_lim3 frld(:,:) = 0.0_wp #endif !----------------------------------------------------------------------- ! Depending on switches call various observation operators !----------------------------------------------------------------------- IF ( numproftypes > 0 ) THEN DO jtype = 1, numproftypes SELECT CASE ( TRIM(obstypesprof(jtype)) ) CASE('prof') profvar1(:,:,:) = tsn(:,:,:,jp_tem) profvar2(:,:,:) = tsn(:,:,:,jp_sal) profmask1(:,:,:) = tmask(:,:,:) profmask2(:,:,:) = tmask(:,:,:) CASE('vel') profvar1(:,:,:) = un(:,:,:) profvar2(:,:,:) = vn(:,:,:) profmask1(:,:,:) = umask(:,:,:) profmask2(:,:,:) = vmask(:,:,:) END SELECT CALL obs_prof_opt( profdataqc(jtype), & & kstp, jpi, jpj, jpk, nit000, idaystp, & & profvar1, profvar2, & & gdept_1d, profmask1, profmask2, n1dint, n2dint, & & kdailyavtypes = dailyavtypes ) END DO ENDIF IF ( numsurftypes > 0 ) THEN DO jtype = 1, numsurftypes SELECT CASE ( TRIM(obstypessurf(jtype)) ) CASE('sst') surfvar(:,:) = tsn(:,:,1,jp_tem) CASE('sla') surfvar(:,:) = sshn(:,:) CASE('sss') surfvar(:,:) = tsn(:,:,1,jp_sal) #if defined key_lim2 || defined key_lim3 CASE('seaice') surfvar(:,:) = 1._wp - frld(:,:) #endif END SELECT CALL obs_surf_opt( surfdatqc(jtype), & & kstp, jpi, jpj, nit000, surfvar, & & tmask(:,:,1), n2dint, ld_sstnight ) END DO ENDIF #if ! defined key_lim2 && ! defined key_lim3 CALL wrk_dealloc(jpi,jpj,frld) #endif END SUBROUTINE dia_obs SUBROUTINE dia_obs_wri !!---------------------------------------------------------------------- !! *** ROUTINE dia_obs_wri *** !! !! ** Purpose : Call observation diagnostic output routines !! !! ** Method : Call observation diagnostic output routines !! !! ** Action : !! !! History : !! ! 06-03 (K. Mogensen) Original code !! ! 06-05 (K. Mogensen) Reformatted !! ! 06-10 (A. Weaver) Cleaning !! ! 07-03 (K. Mogensen) General handling of profiles !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles !!---------------------------------------------------------------------- IMPLICIT NONE !! * Local declarations INTEGER :: jtype ! Data set loop variable !----------------------------------------------------------------------- ! Depending on switches call various observation output routines !----------------------------------------------------------------------- IF ( numproftypes > 0 ) THEN DO jtype = 1, numproftypes CALL obs_prof_decompress( profdataqc(jtype), & & profdata(jtype), .TRUE., numout ) CALL obs_wri_prof( obstypesprof(jtype), profdata(jtype), n2dint ) END DO ENDIF IF ( numsurftypes > 0 ) THEN DO jtype = 1, numsurftypes CALL obs_surf_decompress( surfdatqc(jtype), & & surfdata(jtype), .TRUE., numout ) CALL obs_wri_surf( obstypessurf(jtype), surfdata(jtype), n2dint ) END DO ENDIF END SUBROUTINE dia_obs_wri SUBROUTINE dia_obs_dealloc IMPLICIT NONE !!---------------------------------------------------------------------- !! *** ROUTINE dia_obs_dealloc *** !! !! ** Purpose : To deallocate data to enable the obs_oper online loop. !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri !! !! ** Method : Clean up various arrays left behind by the obs_oper. !! !! ** Action : !! !!---------------------------------------------------------------------- !! obs_grid deallocation CALL obs_grid_deallocate !! diaobs deallocation IF ( numproftypes > 0 ) DEALLOCATE(profdata, profdataqc, nvarsprof, nextrprof) IF ( numsurftypes > 0 ) DEALLOCATE(surfdata, surfdataqc, nvarssurf, nextrsurf) END SUBROUTINE dia_obs_dealloc SUBROUTINE ini_date( ddobsini ) !!---------------------------------------------------------------------- !! *** ROUTINE ini_date *** !! !! ** Purpose : Get initial data in double precision YYYYMMDD.HHMMSS format !! !! ** Method : Get initial data in double precision YYYYMMDD.HHMMSS format !! !! ** Action : Get initial data in double precision YYYYMMDD.HHMMSS format !! !! History : !! ! 06-03 (K. Mogensen) Original code !! ! 06-05 (K. Mogensen) Reformatted !! ! 06-10 (A. Weaver) Cleaning !! ! 06-10 (G. Smith) Calculates initial date the same as method for final date !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 !!---------------------------------------------------------------------- USE phycst, ONLY : & ! Physical constants & rday ! USE daymod, ONLY : & ! Time variables ! & nmonth_len USE dom_oce, ONLY : & ! Ocean space and time domain variables & rdt IMPLICIT NONE !! * Arguments REAL(KIND=dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS !! * Local declarations INTEGER :: iyea ! date - (year, month, day, hour, minute) INTEGER :: imon INTEGER :: iday INTEGER :: ihou INTEGER :: imin INTEGER :: imday ! Number of days in month. REAL(KIND=wp) :: zdayfrc ! Fraction of day INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year !!---------------------------------------------------------------------- !! Initial date initialization (year, month, day, hour, minute) !! (This assumes that the initial date is for 00z)) !!---------------------------------------------------------------------- iyea = ndate0 / 10000 imon = ( ndate0 - iyea * 10000 ) / 100 iday = ndate0 - iyea * 10000 - imon * 100 ihou = 0 imin = 0 !!---------------------------------------------------------------------- !! Compute number of days + number of hours + min since initial time !!---------------------------------------------------------------------- iday = iday + ( nit000 -1 ) * rdt / rday zdayfrc = ( nit000 -1 ) * rdt / rday zdayfrc = zdayfrc - aint(zdayfrc) ihou = int( zdayfrc * 24 ) imin = int( (zdayfrc * 24 - ihou) * 60 ) !!----------------------------------------------------------------------- !! Convert number of days (iday) into a real date !!---------------------------------------------------------------------- CALL calc_month_len( iyea, imonth_len ) DO WHILE ( iday > imonth_len(imon) ) iday = iday - imonth_len(imon) imon = imon + 1 IF ( imon > 12 ) THEN imon = 1 iyea = iyea + 1 CALL calc_month_len( iyea, imonth_len ) ! update month lengths ENDIF END DO !!---------------------------------------------------------------------- !! Convert it into YYYYMMDD.HHMMSS format. !!---------------------------------------------------------------------- ddobsini = iyea * 10000_dp + imon * 100_dp + & & iday + ihou * 0.01_dp + imin * 0.0001_dp END SUBROUTINE ini_date SUBROUTINE fin_date( ddobsfin ) !!---------------------------------------------------------------------- !! *** ROUTINE fin_date *** !! !! ** Purpose : Get final data in double precision YYYYMMDD.HHMMSS format !! !! ** Method : Get final data in double precision YYYYMMDD.HHMMSS format !! !! ** Action : Get final data in double precision YYYYMMDD.HHMMSS format !! !! History : !! ! 06-03 (K. Mogensen) Original code !! ! 06-05 (K. Mogensen) Reformatted !! ! 06-10 (A. Weaver) Cleaning !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 !!---------------------------------------------------------------------- USE phycst, ONLY : & ! Physical constants & rday ! USE daymod, ONLY : & ! Time variables ! & nmonth_len USE dom_oce, ONLY : & ! Ocean space and time domain variables & rdt IMPLICIT NONE !! * Arguments REAL(KIND=dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS !! * Local declarations INTEGER :: iyea ! date - (year, month, day, hour, minute) INTEGER :: imon INTEGER :: iday INTEGER :: ihou INTEGER :: imin INTEGER :: imday ! Number of days in month. REAL(KIND=wp) :: zdayfrc ! Fraction of day INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year !----------------------------------------------------------------------- ! Initial date initialization (year, month, day, hour, minute) ! (This assumes that the initial date is for 00z) !----------------------------------------------------------------------- iyea = ndate0 / 10000 imon = ( ndate0 - iyea * 10000 ) / 100 iday = ndate0 - iyea * 10000 - imon * 100 ihou = 0 imin = 0 !----------------------------------------------------------------------- ! Compute number of days + number of hours + min since initial time !----------------------------------------------------------------------- iday = iday + nitend * rdt / rday zdayfrc = nitend * rdt / rday zdayfrc = zdayfrc - AINT( zdayfrc ) ihou = INT( zdayfrc * 24 ) imin = INT( ( zdayfrc * 24 - ihou ) * 60 ) !----------------------------------------------------------------------- ! Convert number of days (iday) into a real date !---------------------------------------------------------------------- CALL calc_month_len( iyea, imonth_len ) DO WHILE ( iday > imonth_len(imon) ) iday = iday - imonth_len(imon) imon = imon + 1 IF ( imon > 12 ) THEN imon = 1 iyea = iyea + 1 CALL calc_month_len( iyea, imonth_len ) ! update month lengths ENDIF END DO !----------------------------------------------------------------------- ! Convert it into YYYYMMDD.HHMMSS format !----------------------------------------------------------------------- ddobsfin = iyea * 10000_dp + imon * 100_dp + iday & & + ihou * 0.01_dp + imin * 0.0001_dp END SUBROUTINE fin_date END MODULE diaobs