diff --git a/README.md b/README.md index 53e61d70..a816f671 100644 --- a/README.md +++ b/README.md @@ -25,17 +25,20 @@ your public ssh key from Betzy to your github profile. ### Install NorCPM code -Install NorCPM in the nn9039k project space with - +We recommend to create a personal folder in nn9039k under which NorCPM +can be installed, e.g. mkdir -p /cluster/projects/nn9039k/people/$USER cd /cluster/projects/nn9039k/people/$USER + +Next, download the code with git clone ssh://git@github.com/NorESMhub/NorCPM.git NorCPM In case `git clone` throws a `permission denied` error then use instead git clone https://github.com/NorESMhub/NorCPM.git NorCPM -NorCPM is now installed in `/cluster/projects/nn9039k/people/$USER/NorCPM` +In the following, we refer to the location where NorCPM is installed +as NORCPMROOT. ## Setting up and running experiments @@ -306,6 +309,7 @@ General settings Assimilation settings ASSIMROOT : Location of assimilation code + MEAN_MOD_DIR : Location where model climatologies are stored (for anomaly DA) NTASKS_DA : total number of mpi-tasks available for assimilation NTASKS_ENKF : number of mpi-tasks used for EnKF OCNGRIDFILE : path to ocean grid file diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/DA_start b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/DA_start deleted file mode 100755 index 8e28d2a7..00000000 Binary files a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/DA_start and /dev/null differ diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/includedSupportPackages.txt b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/includedSupportPackages.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/mccExcludedFiles.log b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/mccExcludedFiles.log deleted file mode 100644 index 7b76dc38..00000000 --- a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/mccExcludedFiles.log +++ /dev/null @@ -1,2 +0,0 @@ -Excluded Files -Excluded Files Exclusion Message ID Reason For Exclusion Exclusion Rule diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/readme.txt b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/readme.txt deleted file mode 100644 index 9b84e2b8..00000000 --- a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/readme.txt +++ /dev/null @@ -1,103 +0,0 @@ -DA_start Executable - -1. Prerequisites for Deployment - -Verify that MATLAB Runtime(R2022b) is installed. -If not, you can run the MATLAB Runtime installer. -To find its location, enter - - >>mcrinstaller - -at the MATLAB prompt. - -Alternatively, download and install the Linux version of the MATLAB Runtime for R2022b -from the following link on the MathWorks website: - - https://www.mathworks.com/products/compiler/mcr/index.html - -For more information about the MATLAB Runtime and the MATLAB Runtime installer, see -"Distribute Applications" in the MATLAB Compiler documentation -in the MathWorks Documentation Center. - -2. Files to Deploy and Package - -Files to Package for Standalone -================================ --DA_start --run_DA_start.sh (shell script for temporarily setting environment variables and - executing the application) - -to run the shell script, type - - ./run_DA_start.sh - - at Linux or Mac command prompt. is the directory - where MATLAB Runtime(R2022b) is installed or the directory where - MATLAB is installed on the machine. is all the - arguments you want to pass to your application. For example, - - If you have MATLAB Runtime(R2022b) installed in - /mathworks/home/application/R2022b, run the shell script as: - - ./run_DA_start.sh /mathworks/home/application/R2022b - - If you have MATLAB installed in /mathworks/devel/application/matlab, - run the shell script as: - - ./run_DA_start.sh /mathworks/devel/application/matlab --MCRInstaller.zip - Note: if end users are unable to download the MATLAB Runtime using the - instructions in the previous section, include it when building your - component by clicking the "Runtime included in package" link in the - Deployment Tool. --This readme file - - - -3. Definitions - -For information on deployment terminology, go to -https://www.mathworks.com/help and select MATLAB Compiler > -Getting Started > About Application Deployment > -Deployment Product Terms in the MathWorks Documentation -Center. - -4. Appendix - -A. Linux systems: -In the following directions, replace MR/R2022b by the directory on the target machine - where MATLAB is installed, or MR by the directory where the MATLAB Runtime is - installed. - -(1) Set the environment variable XAPPLRESDIR to this value: - -MR/R2022b/X11/app-defaults - - -(2) If the environment variable LD_LIBRARY_PATH is undefined, set it to the following: - -MR/R2022b/runtime/glnxa64:MR/R2022b/bin/glnxa64:MR/R2022b/sys/os/glnxa64:MR/R2022b/sys/opengl/lib/glnxa64 - -If it is defined, set it to the following: - -${LD_LIBRARY_PATH}:MR/R2022b/runtime/glnxa64:MR/R2022b/bin/glnxa64:MR/R2022b/sys/os/glnxa64:MR/R2022b/sys/opengl/lib/glnxa64 - - For more detailed information about setting the MATLAB Runtime paths, see Package and - Distribute in the MATLAB Compiler documentation in the MathWorks Documentation Center. - - - - NOTE: To make these changes persistent after logout on Linux - or Mac machines, modify the .cshrc file to include this - setenv command. - NOTE: The environment variable syntax utilizes forward - slashes (/), delimited by colons (:). - NOTE: When deploying standalone applications, you can - run the shell script file run_DA_start.sh - instead of setting environment variables. See - section 2 "Files to Deploy and Package". - - - - - - diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/requiredMCRProducts.txt b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/requiredMCRProducts.txt deleted file mode 100644 index 4a61636f..00000000 --- a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/requiredMCRProducts.txt +++ /dev/null @@ -1 +0,0 @@ -35010 35002 35003 \ No newline at end of file diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/run_DA_start.sh b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/run_DA_start.sh deleted file mode 100755 index e8140d65..00000000 --- a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/run_DA_start.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -# script for execution of deployed applications -# -# Sets up the MATLAB Runtime environment for the current $ARCH and executes -# the specified command. -# -exe_name=$0 -exe_dir=`dirname "$0"` -echo "------------------------------------------" -if [ "x$1" = "x" ]; then - echo Usage: - echo $0 \ args -else - echo Setting up environment variables - MCRROOT="$1" - echo --- - LD_LIBRARY_PATH=.:${MCRROOT}/runtime/glnxa64 ; - LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${MCRROOT}/bin/glnxa64 ; - LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${MCRROOT}/sys/os/glnxa64; - LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${MCRROOT}/sys/opengl/lib/glnxa64; - export LD_LIBRARY_PATH; - echo LD_LIBRARY_PATH is ${LD_LIBRARY_PATH}; -# Preload glibc_shim in case of RHEL7 variants - test -e /usr/bin/ldd && ldd --version | grep -q "(GNU libc) 2\.17" \ - && export LD_PRELOAD="${MCRROOT}/bin/glnxa64/glibc-2.17_shim.so" - shift 1 - args= - while [ $# -gt 0 ]; do - token=$1 - args="${args} \"${token}\"" - shift - done - eval "\"${exe_dir}/DA_start\"" $args -fi -exit - diff --git a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/unresolvedSymbols.txt b/assim/enkf_cf-system2_old/DA_startstandaloneApplication/unresolvedSymbols.txt deleted file mode 100644 index 7c2fc16c..00000000 --- a/assim/enkf_cf-system2_old/DA_startstandaloneApplication/unresolvedSymbols.txt +++ /dev/null @@ -1 +0,0 @@ -Path Symbol Reason diff --git a/assim/enkf_cf-system2_old/EnKF/EnKF.F90 b/assim/enkf_cf-system2_old/EnKF/EnKF.F90 deleted file mode 100755 index 1e68f67c..00000000 --- a/assim/enkf_cf-system2_old/EnKF/EnKF.F90 +++ /dev/null @@ -1,469 +0,0 @@ -! File: EnKF.F90 -! -! Created: ??? -! -! Last modified: 20/04/2010 -! -! Purpose: Main program for EnKF analysis -! -! Description: The workflow is as follows: -! -- read model parameters -! -- read obs -! -- conduct necessary pre-processing of obs (superobing) -! -- calculate ensemble observations -! -- calculate X5 -! -- update the ensemble -! -! Modifications: -! 14/07/2017 MK: -! added flag TRIPOLAR to MODEL.CPP, code adapted -! to distinguish between tripolar and bipolar grid -! 15/09/2014 YW: Coupling automatically layer thicknesses to preserve -! the non-negativity of DP. The list of modified files is as follows: -! -- distribute.F90 -! -- m_local_analysis.F90 -! 28/10/2011 FC: The code is adapted to work with micom -! 20/9/2011 PS: -! Modified code to allow individual inflations for each of -! `NFIELD' fields updated in a batch - thanks to Ehouarn Simon -! for spotting this inconsistency -! 6/8/2010 PS: -! Small changes in calls to calc_X5() and update_fields() to -! reflect changes in interfaces. -! 6/7/2010 PS: -! Moved point output to a separate module m_point2nc.F90 -! 25/5/2010 PS: -! Added inflation as a 4th command line argument -! 20/5/2010 PS: -! Set NFIELD = 4. This requires 4 GB per node in TOPAZ and -! "medium" memory model on Hexagon (a single allocation for a -! variable over 2GB) -! 20/4/2010 PS: -! Set NFIELD = 4. This will require 2 GB per node in TOPAZ. -! Thanks to Alok Gupta for hinting this possibility. -! 10/4/2010 PS: -! Moved variable `field' from real(8) to real(4); -! set NFIELD = 2. -! Prior history: -! Not documented. - -program EnKF -#if defined(QMPI) - use qmpi -#else - use qmpi_fake -#endif - use m_parameters - use distribute - use mod_measurement - use m_get_micom_nrens - use m_get_micom_grid - use m_get_micom_dim - use m_get_cice_dim - use m_obs - use m_local_analysis - use m_prep_4_EnKF - use m_set_random_seed2 - use m_get_micom_fld - use m_put_micom_fld - use mod_analysisfields - use m_parse_blkdat - use m_random - use m_point2nc - use netcdf - use nfw_mod - implicit none - - !=============================================================================== - ! VARIABLE DEFINITION - !=============================================================================== - character(*), parameter :: ENKF_VERSION = "2.11" - - integer, external :: iargc - - ! NFIELD is the number of fields (x N) passed for the update during a call to - ! update_fields(). In TOPAZ4 NFIELD = 2 if there is 1 GB of RAM per node, and - ! NFIELD = 4 if there are 2 GB of RAM. Higher value of NFIELD reduces the - ! number of times X5tmp.uf is read from disk, which is the main bottleneck - ! for the analysis time right now. - ! - integer, parameter :: NFIELD = 53 - - character(512) :: options - - integer :: nrens - real, allocatable, dimension(:,:) :: modlon, modlat, depths, readfld, readfld2 - real, allocatable, dimension(:,:) :: S ! ensemble observations HE - real, allocatable, dimension(:) :: d ! d - Hx - - integer k, m - - ! "New" variables used in the parallelization - integer, dimension(:,:), allocatable :: nlobs_array - real(4), allocatable :: fld(:,:),dpfld(:,:),fld_ave(:),nb_ave(:) - real(8) rtc, time0, time1, time2 - - ! Additional fields - character(len=3) :: cmem - character(len=80) :: memfile - integer :: fieldcounter - - character(100) :: text_string - - real :: rdummy - integer :: idm, jdm, kdm - integer :: jjdm !for output, tripolar grid dependent - -#if defined(ICE) - integer :: ncat, ikdm, skdm, nrens_ice - -#endif - integer :: i - - real :: mindx - real :: meandx - integer :: m1, m2, nfields - real :: infls(NFIELD) - logical :: isdp(NFIELD) - -#if defined(QMPI) - call start_mpi() -#endif - - !=============================================================================== - ! Read the characteristics of the assimilation to be carried out. - !=============================================================================== - - if (iargc() /= 1) then - print *, 'Usage: EnKF ' - print *, ' EnKF -h' - print *, 'Options:' - print *, ' -h -- describe parameter fie format' - call stop_mpi() - else - call getarg(1, options) - if (trim(options) == "-h") then - call prm_describe() - call stop_mpi() - end if - end if - - if (master) then - print * - print '(a, a)', ' EnKF version ', ENKF_VERSION - print * - end if - - call prm_read() - call prm_print() - - ! get model dimensions - !29/05/2015 Add reading of kdm - call get_micom_dim(idm,jdm,kdm) - jjdm = jdm - - if (master) then - print *, 'read dimension idm,jdm,kdm :',idm,jdm,kdm - end if - -#if defined(ICE) - call get_cice_dim(ncat,ikdm,skdm) - - if (master) then - print *, 'read cice dimension ncat,ntilyr,ntslyr :',ncat,ikdm,skdm - end if -#endif - - allocate(modlon(idm,jdm)) - allocate(readfld(idm,jdm)) - allocate(readfld2(idm,jdm)) - allocate(modlat(idm,jdm)) - allocate(depths(idm,jdm)) - allocate(nlobs_array(idm, jdm)) - ! get model grid - ! - - - call get_micom_grid(modlon, modlat, depths, mindx, meandx, idm, jdm) - if (master) then - print *,'MEAN grid size and min from scpx/scpy :',meandx,mindx - print *,'min/max depth :',minval(depths(:,:)),maxval(depths(:,:)) - end if - - - - ! set a variable random seed - ! - !call set_random_seed3 - !===================================================== - - ! initialise point output - ! - call p2nc_init - - time0 = rtc() - - ! read measurements - ! - if (master) then - print *, 'EnKF: reading observations' - end if - call obs_readobs - if (master) then - print '(a, i6)', ' # of obs = ', nobs - print '(a, a, a, e10.3, a, e10.3)', ' first obs = "', trim(obs(1) % id),& - '", v = ', obs(1) % d, ', var = ', obs(1) % var - print '(a, a, a, e10.3, a, e10.3)', ' last obs = "', trim(obs(nobs) % id),& - '", v = ', obs(nobs) % d, ', var = ', obs(nobs) % var - end if - if (master) then - print * - end if - - ! read ensemble size and store in A - ! - nrens = get_micom_nrens(idm, jdm) - if (master) then - print '(a, i5, a)', ' EnKF: ', nrens, ' ensemble members found' - end if - if (ENSSIZE > 0) then - ENSSIZE = min(nrens, ENSSIZE) - else - ENSSIZE = nrens - end if - !==================================================================== -#if defined(ICE) - nrens_ice = get_cice_nrens(idm, jdm)!MK: idm, jdm not needed - - if (nrens /= nrens_ice) then - print *, 'EnKF: ensemble numbers of' - print *, ' forecast.nc and ' - print *, ' forecast_ice.nc' - print *, ' do not agree. STOP.' - call stop_mpi() - end if -#endif - !==================================================================== - - if (master) then - print '(a, i4, a)', ' EnKF: ', ENSSIZE, ' ensemble members used' - end if - if (master) then - print * - end if - - ! PS - preprocess the obs using the information about the ensemble fields - ! here (if necessary), before running prep_4_EnKF(). This is necessary e.g. - ! for assimilating in-situ data because of the dynamic vertical geometry in - ! HYCOM - ! - call obs_prepareobs - - allocate(S(nobs, ENSSIZE), d(nobs)) -#if defined(ICE) - call prep_4_EnKF(ENSSIZE, d, S, depths, meandx / 1000.0, idm, jdm, kdm, ncat) -#else - call prep_4_EnKF(ENSSIZE, d, S, depths, meandx / 1000.0, idm, jdm, kdm) -#endif - if (master) then - print *, 'EnKF: finished initialisation, time = ', rtc() - time0 - end if - - ! (no parallelization was required before this point) - - time1 = rtc() - - allocate(X5(ENSSIZE, ENSSIZE, idm)) - allocate(X5check(ENSSIZE, ENSSIZE, idm)) - call calc_X5(ENSSIZE, modlon, modlat, depths, mindx, meandx, d, S,& - LOCRAD, RFACTOR2, nlobs_array, idm, jdm) - deallocate(d, S, X5check) - if (master) then - print *, 'EnKF: finished calculation of X5, time = ', rtc() - time0 - end if - - allocate(fld(idm * jdm, ENSSIZE * NFIELD)) - -#if defined(QMPI) - call barrier() -#endif - - ! get fieldnames and fieldlevels - ! - call get_analysisfields() - call distribute_iterations_field(numfields,fieldnames,fieldlevel) - -#if defined(QMPI) - call barrier() !KAL - just for "niceness" of output -#endif - time2 = rtc() - do m1 = my_first_iteration, my_last_iteration, NFIELD - m2 = min(my_last_iteration, m1 + NFIELD - 1) - nfields = m2 - m1 + 1 - - do m = m1, m2 -!29/05/2015 fanf add 3 digit to qmpi -! print '(a, i3, a, i3, a, a6, a, i3, a, f11.0)',& -! "I am ", qmpi_proc_num, ', m = ', m, ", field = ",& -! fieldnames(m), ", k = ", fieldlevel(m), ", time = ",& -! rtc() - time2 - if ( trim(fieldnames(m)) /= 'dp' .and. fieldlevel(m)>=3 .and. trim(rstcode(m))=='o') then - allocate(dpfld(idm * jdm, ENSSIZE)) - allocate(fld_ave(idm * jdm)) - allocate(nb_ave(idm * jdm)) - fld_ave(:)=0 - nb_ave(:)=0 - dpfld(:,:)=0 - elseif ( trim(fieldnames(m)) == 'Tsfcn' .and. trim(rstcode(m))=='i') then - ! here we prepare the replacement of invalid values fro Tsfcn with its ensemble mean of valid values - ! to avoid artifical drift in those points due to nan values - allocate(dpfld(idm * jdm, ENSSIZE)) ! dpfld - allocate(fld_ave(idm * jdm)) - allocate(nb_ave(idm * jdm)) - fld_ave(:)=0 - nb_ave(:)=0 - dpfld(:,:)=0 - endif ! not dp - do k = 1, ENSSIZE - write(cmem, '(i3.3)') k - if (trim(rstcode(m))=='o') then - memfile = 'forecast' // cmem -#if defined(TRIPOLAR) - jjdm = jdm -#endif - elseif (trim(rstcode(m))=='i') then - memfile = 'forecast_ice' // cmem -#if defined(TRIPOLAR) - jjdm = jdm-1 -#endif - else - print *,'rstcode unrecognised ',rstcode(m) - print *,'memfile set empty' - memfile = '' - endif - - ! reshaping and conversion to real(4) - if (trim(rstcode(m))=='i') then - call get_micom_fld_ice(trim(memfile), readfld, fieldnames(m),& - fieldlevel(m), 1, idm, jdm) - else - call get_micom_fld_new(trim(memfile), readfld, fieldnames(m),& - fieldlevel(m), 1, idm, jdm) - endif - - fld(:, ENSSIZE * (m - m1) + k) = reshape(readfld, (/idm * jdm/)) - - !ocean variable not in ML - if ( trim(fieldnames(m)) /= 'dp' .and. fieldlevel(m)>=3 .and. trim(rstcode(m))=='o') then - call get_micom_fld_new(trim(memfile), readfld2, 'dp',& - fieldlevel(m), 1, idm, jdm) - ! reshaping and conversion to real(4) - dpfld(:, k) = reshape(readfld2, (/idm * jdm/)) - !10 cm - where(dpfld(:, k)>9806.) - fld_ave=fld_ave+reshape(readfld, (/idm * jdm/)) - nb_ave=nb_ave+1 - endwhere - elseif ( trim(fieldnames(m)) == 'Tsfcn' .and. trim(rstcode(m))=='i') then - call get_micom_fld_ice(trim(memfile), readfld2, 'aicen',& - fieldlevel(m), 1, idm, jdm) - ! reshaping and conversion to real(4) - dpfld(:, k) = reshape(readfld2, (/idm * jdm/)) - where(dpfld(:, k)>0.) - fld_ave=fld_ave+reshape(readfld, (/idm * jdm/)) - nb_ave=nb_ave+1 - endwhere - end if ! not dp - end do !ens size - - !filled up empty layer with ensemble average value - if ( trim(fieldnames(m)) /= 'dp' .and. fieldlevel(m)>=3 .and. trim(rstcode(m))=='o') then - do k = 1, ENSSIZE - do i = 1, idm*jdm - !10 cm - if( dpfld(i, k)<9806. .and. nb_ave(i)>0 ) then - fld(i, ENSSIZE * (m - m1) + k)= fld_ave(i)/nb_ave(i); - endif - enddo - enddo - deallocate(dpfld,fld_ave,nb_ave) - elseif ( trim(fieldnames(m)) == 'Tsfcn' .and. trim(rstcode(m))=='i') then - do k = 1, ENSSIZE - do i = 1, idm*jdm - !10 cm - if( dpfld(i, k)<0. .and. nb_ave(i)>0 ) then - fld(i, ENSSIZE * (m - m1) + k)= fld_ave(i)/nb_ave(i); - endif - enddo - enddo - deallocate(dpfld,fld_ave,nb_ave) - endif ! not dp - - call p2nc_storeforecast(idm, jdm, ENSSIZE, numfields, m, fld(:, ENSSIZE * (m - m1) + 1 : ENSSIZE * (m + 1 - m1))) - infls(m - m1 + 1) = prm_getinfl(trim(fieldnames(m))); - isdp(m - m1 + 1) = (trim(fieldnames(m)) == 'dp' ) - end do - - call update_fields(idm, jdm, ENSSIZE, nfields, nlobs_array, depths,& - fld(1,1), infls, isdp) - - do m = m1, m2 - fieldcounter = (m - my_first_iteration) + 1 - do k = 1, ENSSIZE - write(cmem,'(i3.3)') k - if (trim(rstcode(m))=='o') then - memfile = 'forecast' // cmem -#if defined(TRIPOLAR) - jjdm=jdm -#endif - elseif (trim(rstcode(m))=='i') then - memfile = 'forecast_ice' // cmem -#if defined(TRIPOLAR) - jjdm=jdm-1 -#endif - else - print *,'rstcode unrecognised ',rstcode(m) - print *,'memfile set empty' - memfile = '' - endif - - ! reshaping and conversion to real(8) - readfld = reshape(fld(:, ENSSIZE * (m - m1) + k), (/idm, jdm/)) - call put_micom_fld(trim(memfile), readfld(:,1:jjdm), k,& - fieldnames(m), fieldlevel(m), 1, idm, jjdm) - end do - end do - - end do - deallocate(X5) - deallocate(fld) - - call p2nc_writeforecast - - ! Barrier only necessary for timings -#if defined(QMPI) - call barrier() -#endif - if (master) then - print *, 'EnKF: time for initialization = ', time1 - time0 - print *, 'EnKF: time for X5 calculation = ', time2 - time1 - print *, 'EnKF: time for ensemble update = ', rtc() - time2 - print *, 'EnKF: total time = ', rtc() - time0 - end if -#if defined(QMPI) - call barrier() -#endif - print *, 'EnKF: Finished' - call stop_mpi() -end program EnKF - -#if defined(_G95_) -! not tested! - PS -! -real function rtc() - integer :: c - - call system_clock(count=c) - rtc = dfloat(c) -end function rtc -#endif diff --git a/assim/enkf_cf-system2_old/EnKF/MODEL.CPP b/assim/enkf_cf-system2_old/EnKF/MODEL.CPP deleted file mode 100755 index 1f8775eb..00000000 --- a/assim/enkf_cf-system2_old/EnKF/MODEL.CPP +++ /dev/null @@ -1,9 +0,0 @@ -#undef TEST_2D -#undef LINUX -#undef DEBUG -#undef TEST_1D -#define ICE -#define ANOMALY -#define EXPCOV -#undef CHECK_SOLUTION -#undef X4SVD diff --git a/assim/enkf_cf-system2_old/EnKF/cfortran.h b/assim/enkf_cf-system2_old/EnKF/cfortran.h deleted file mode 100755 index 5340cafb..00000000 --- a/assim/enkf_cf-system2_old/EnKF/cfortran.h +++ /dev/null @@ -1,2422 +0,0 @@ -/* cfortran.h 4.4 */ -/* http://www-zeus.desy.de/~burow/cfortran/ */ -/* Burkhard Burow burow@desy.de 1990 - 2002. */ - -#ifndef __CFORTRAN_LOADED -#define __CFORTRAN_LOADED - -/* - THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU - SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING, - MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE. -*/ - -/* The following modifications were made by the authors of CFITSIO or by me. - * I've flagged them below with "(CFITSIO)" or "(KMCCARTY)". - * PDW = Peter Wilson - * DM = Doug Mink - * LEB = ?? - * -- Kevin McCarty, for Debian (11/29/2003) */ - -/******* - Modifications: - Oct 1997: Changed symbol name extname to appendus (PDW/HSTX) - (Conflicted with a common variable name in FTOOLS) - Nov 1997: If g77Fortran defined, also define f2cFortran (PDW/HSTX) - Feb 1998: Let VMS see the NUM_ELEMS code. Lets programs treat - single strings as vectors with single elements - Nov 1999: If macintoxh defined, also define f2cfortran (for Mac OS-X) - Apr 2000: If WIN32 defined, also define PowerStationFortran and - VISUAL_CPLUSPLUS (Visual C++) - Jun 2000: If __GNUC__ and linux defined, also define f2cFortran - (linux/gcc environment detection) - Apr 2002: If __CYGWIN__ is defined, also define f2cFortran - Nov 2002: If __APPLE__ defined, also define f2cfortran (for Mac OS-X) - - Nov 2003: If __INTEL_COMPILER or INTEL_COMPILER defined, also define - f2cFortran (KMCCARTY) - *******/ - -/* - Avoid symbols already used by compilers and system *.h: - __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c - - */ - - -/* First prepare for the C compiler. */ - -#ifndef ANSI_C_preprocessor /* i.e. user can override. */ -#ifdef __CF__KnR -#define ANSI_C_preprocessor 0 -#else -#ifdef __STDC__ -#define ANSI_C_preprocessor 1 -#else -#define _cfleft 1 -#define _cfright -#define _cfleft_cfright 0 -#define ANSI_C_preprocessor _cfleft/**/_cfright -#endif -#endif -#endif - -#if ANSI_C_preprocessor -#define _0(A,B) A##B -#define _(A,B) _0(A,B) /* see cat,xcat of K&R ANSI C p. 231 */ -#define _2(A,B) A##B /* K&R ANSI C p.230: .. identifier is not replaced */ -#define _3(A,B,C) _(A,_(B,C)) -#else /* if it turns up again during rescanning. */ -#define _(A,B) A/**/B -#define _2(A,B) A/**/B -#define _3(A,B,C) A/**/B/**/C -#endif - -#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__)) -#define VAXUltrix -#endif - -#include /* NULL [in all machines stdio.h] */ -#include /* strlen, memset, memcpy, memchr. */ -#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) ) -#include /* malloc,free */ -#else -#include /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/ -#ifdef apollo -#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */ -#endif -#endif - -#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx)) -#define __CF__KnR /* Sun, LynxOS and VAX Ultrix cc only supports K&R. */ - /* Manually define __CF__KnR for HP if desired/required.*/ -#endif /* i.e. We will generate Kernighan and Ritchie C. */ -/* Note that you may define __CF__KnR before #include cfortran.h, in order to -generate K&R C instead of the default ANSI C. The differences are mainly in the -function prototypes and declarations. All machines, except the Apollo, work -with either style. The Apollo's argument promotion rules require ANSI or use of -the obsolete std_$call which we have not implemented here. Hence on the Apollo, -only C calling FORTRAN subroutines will work using K&R style.*/ - - -/* Remainder of cfortran.h depends on the Fortran compiler. */ - -/* 11/29/2003 (KMCCARTY): add *INTEL_COMPILER symbols here */ -#if defined(CLIPPERFortran) || defined(pgiFortran) || defined(__INTEL_COMPILER) || defined(INTEL_COMPILER) -#define f2cFortran -#endif - -/* VAX/VMS does not let us \-split long #if lines. */ -/* Split #if into 2 because some HP-UX can't handle long #if */ -#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)) -#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran)) -/* If no Fortran compiler is given, we choose one for the machines we know. */ -#if defined(lynx) || defined(VAXUltrix) -#define f2cFortran /* Lynx: Only support f2c at the moment. - VAXUltrix: f77 behaves like f2c. - Support f2c or f77 with gcc, vcc with f2c. - f77 with vcc works, missing link magic for f77 I/O.*/ -#endif -/* 04/13/00 DM (CFITSIO): Add these lines for NT */ -/* with PowerStationFortran and and Visual C++ */ -#if defined(WIN32) && !defined(__CYGWIN__) -#define PowerStationFortran -#define VISUAL_CPLUSPLUS -#endif -#if defined(g77Fortran) /* 11/03/97 PDW (CFITSIO) */ -#define f2cFortran -#endif -#if defined(__CYGWIN__) /* 04/11/02 LEB (CFITSIO) */ -#define f2cFortran -#endif -/* commented out -- PS - * #if defined(__GNUC__) && defined(linux) - * #define f2cFortran - * #error f2cFortran:5 - * #endif - */ -#if defined(macintosh) /* 11/1999 (CFITSIO) */ -#define f2cFortran -#endif -#if defined(__APPLE__) /* 11/2002 (CFITSIO) */ -#define f2cFortran -#endif -#if defined(g95Fortran) /* 01/04/05 PS */ -#define f2cFortran -#endif -#if defined(__hpux) /* 921107: Use __hpux instead of __hp9000s300 */ -#define hpuxFortran /* Should also allow hp9000s7/800 use.*/ -#endif -#if defined(apollo) -#define apolloFortran /* __CF__APOLLO67 also defines some behavior. */ -#endif -#if defined(sun) || defined(__sun) -#define sunFortran -#endif -#if defined(_IBMR2) -#define IBMR2Fortran -#endif -#if defined(_CRAY) -#define CRAYFortran /* _CRAYT3E also defines some behavior. */ -#endif -#if defined(_SX) -#define SXFortran -#endif -#if defined(mips) || defined(__mips) -#define mipsFortran -#endif -#if defined(vms) || defined(__vms) -#define vmsFortran -#endif -#if defined(__alpha) && defined(__unix__) -#define DECFortran -#endif -#if defined(__convex__) -#define CONVEXFortran -#endif -#if defined(VISUAL_CPLUSPLUS) -#define PowerStationFortran -#endif -#endif /* ...Fortran */ -#endif /* ...Fortran */ - -/* Split #if into 2 because some HP-UX can't handle long #if */ -#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)) -#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran)) -/* If your compiler barfs on ' #error', replace # with the trigraph for # */ - #error "cfortran.h: Can't find your environment among:\ - - GNU gcc (g77) on Linux. \ - - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...) \ - - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000 \ - - VAX VMS CC 3.1 and FORTRAN 5.4. \ - - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0. \ - - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2 \ - - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7. \ - - CRAY \ - - NEC SX-4 SUPER-UX \ - - CONVEX \ - - Sun \ - - PowerStation Fortran with Visual C++ \ - - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730 \ - - LynxOS: cc or gcc with f2c. \ - - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77. \ - - f77 with vcc works; but missing link magic for f77 I/O. \ - - NO fort. None of gcc, cc or vcc generate required names.\ - - f2c : Use #define f2cFortran, or cc -Df2cFortran \ - - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran \ - - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \ - - Absoft Pro Fortran: Use #define AbsoftProFortran \ - - Portland Group Fortran: Use #define pgiFortran \ - - Intel Fortran: Use #define INTEL_COMPILER" -/* Compiler must throw us out at this point! */ -#endif -#endif - - -#if defined(VAXC) && !defined(__VAXC) -#define OLD_VAXC -#pragma nostandard /* Prevent %CC-I-PARAMNOTUSED. */ -#endif - -/* Throughout cfortran.h we use: UN = Uppercase Name. LN = Lowercase Name. */ - -/* "extname" changed to "appendus" below (CFITSIO) */ -#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(appendus) -#define CFC_(UN,LN) _(LN,_) /* Lowercase FORTRAN symbols. */ -#define orig_fcallsc(UN,LN) CFC_(UN,LN) -#else -#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran) -#ifdef _CRAY /* (UN), not UN, circumvents CRAY preprocessor bug. */ -#define CFC_(UN,LN) (UN) /* Uppercase FORTRAN symbols. */ -#else /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */ -#define CFC_(UN,LN) UN /* Uppercase FORTRAN symbols. */ -#endif -#define orig_fcallsc(UN,LN) CFC_(UN,LN) /* CRAY insists on arg.'s here. */ -#else /* For following machines one may wish to change the fcallsc default. */ -#define CF_SAME_NAMESPACE -#ifdef vmsFortran -#define CFC_(UN,LN) LN /* Either case FORTRAN symbols. */ - /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/ - /* because VAX/VMS doesn't do recursive macros. */ -#define orig_fcallsc(UN,LN) UN -#else /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */ -#define CFC_(UN,LN) LN /* Lowercase FORTRAN symbols. */ -#define orig_fcallsc(UN,LN) CFC_(UN,LN) -#endif /* vmsFortran */ -#endif /* CRAYFortran PowerStationFortran */ -#endif /* ....Fortran */ - -#define fcallsc(UN,LN) orig_fcallsc(UN,LN) -#define preface_fcallsc(P,p,UN,LN) CFC_(_(P,UN),_(p,LN)) -#define append_fcallsc(P,p,UN,LN) CFC_(_(UN,P),_(LN,p)) - -#define C_FUNCTION(UN,LN) fcallsc(UN,LN) -#define FORTRAN_FUNCTION(UN,LN) CFC_(UN,LN) - -#ifndef COMMON_BLOCK -#ifndef CONVEXFortran -#ifndef CLIPPERFortran -#if !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)) -#define COMMON_BLOCK(UN,LN) CFC_(UN,LN) -#else -#define COMMON_BLOCK(UN,LN) _(_C,LN) -#endif /* AbsoftUNIXFortran or AbsoftProFortran */ -#else -#define COMMON_BLOCK(UN,LN) _(LN,__) -#endif /* CLIPPERFortran */ -#else -#define COMMON_BLOCK(UN,LN) _3(_,LN,_) -#endif /* CONVEXFortran */ -#endif /* COMMON_BLOCK */ - -#ifndef DOUBLE_PRECISION -#if defined(CRAYFortran) && !defined(_CRAYT3E) -#define DOUBLE_PRECISION long double -#else -#define DOUBLE_PRECISION double -#endif -#endif - -#ifndef FORTRAN_REAL -#if defined(CRAYFortran) && defined(_CRAYT3E) -#define FORTRAN_REAL double -#else -#define FORTRAN_REAL float -#endif -#endif - -#ifdef CRAYFortran -#ifdef _CRAY -#include -#else -#include "fortran.h" /* i.e. if crosscompiling assume user has file. */ -#endif -#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *) /* Used for C calls FORTRAN. */ -/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/ -#define VOIDP (void *) /* When FORTRAN calls C, we don't know if C routine - arg.'s have been declared float *, or double *. */ -#else -#define FLOATVVVVVVV_cfPP -#define VOIDP -#endif - -#ifdef vmsFortran -#if defined(vms) || defined(__vms) -#include -#else -#include "descrip.h" /* i.e. if crosscompiling assume user has file. */ -#endif -#endif - -#ifdef sunFortran -#if defined(sun) || defined(__sun) -#include /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT. */ -#else -#include "math.h" /* i.e. if crosscompiling assume user has file. */ -#endif -/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3, - * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in - * , since sun C no longer promotes C float return values to doubles. - * Therefore, only use them if defined. - * Even if gcc is being used, assume that it exhibits the Sun C compiler - * behavior in order to be able to use *.o from the Sun C compiler. - * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc. - */ -#endif - -#ifndef apolloFortran -/* "extern" removed (CFITSIO) */ -#define COMMON_BLOCK_DEF(DEFINITION, NAME) /* extern */ DEFINITION NAME -#define CF_NULL_PROTO -#else /* HP doesn't understand #elif. */ -/* Without ANSI prototyping, Apollo promotes float functions to double. */ -/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */ -#define CF_NULL_PROTO ... -#ifndef __CF__APOLLO67 -#define COMMON_BLOCK_DEF(DEFINITION, NAME) \ - DEFINITION NAME __attribute((__section(NAME))) -#else -#define COMMON_BLOCK_DEF(DEFINITION, NAME) \ - DEFINITION NAME #attribute[section(NAME)] -#endif -#endif - -#ifdef __cplusplus -#undef CF_NULL_PROTO -#define CF_NULL_PROTO ... -#endif - - -#ifndef USE_NEW_DELETE -#ifdef __cplusplus -#define USE_NEW_DELETE 1 -#else -#define USE_NEW_DELETE 0 -#endif -#endif -#if USE_NEW_DELETE -#define _cf_malloc(N) new char[N] -#define _cf_free(P) delete[] P -#else -#define _cf_malloc(N) (char *)malloc(N) -#define _cf_free(P) free(P) -#endif - -#ifdef mipsFortran -#define CF_DECLARE_GETARG int f77argc; char **f77argv -#define CF_SET_GETARG(ARGC,ARGV) f77argc = ARGC; f77argv = ARGV -#else -#define CF_DECLARE_GETARG -#define CF_SET_GETARG(ARGC,ARGV) -#endif - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define AcfCOMMA , -#define AcfCOLON ; - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES USED WITHIN CFORTRAN.H */ - -#define _cfMIN(A,B) (As) { /* Need this to handle NULL string.*/ - while (e>s && *--e==t); /* Don't follow t's past beginning. */ - e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */ -} return s; } - -/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally -points to the terminating '\0' of s, but may actually point to anywhere in s. -s's new '\0' will be placed at e or earlier in order to remove any trailing t's. -If es) { /* Watch out for neg. length string.*/ - while (e>s && *--e==t); /* Don't follow t's past beginning. */ - e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */ -} return s; } - -/* Note the following assumes that any element which has t's to be chopped off, -does indeed fill the entire element. */ -#ifndef __CF__KnR -static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t) -#else -static char *vkill_trailing( cstr, elem_len, sizeofcstr, t) - char* cstr; int elem_len; int sizeofcstr; char t; -#endif -{ int i; -for (i=0; i= 4.3 gives message: - zow35> cc -c -DDECFortran cfortest.c - cfe: Fatal: Out of memory: cfortest.c - zow35> - Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine - if using -Aa, otherwise we have a problem. - */ -#ifndef MAX_PREPRO_ARGS -#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR))) -#define MAX_PREPRO_ARGS 31 -#else -#define MAX_PREPRO_ARGS 99 -#endif -#endif - -#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -/* In addition to explicit Absoft stuff, only Absoft requires: - - DEFAULT coming from _cfSTR. - DEFAULT could have been called e.g. INT, but keep it for clarity. - - M term in CFARGT14 and CFARGT14FS. - */ -#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0) -#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0) -#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0) -#define DEFAULT_cfABSOFT1 -#define LOGICAL_cfABSOFT1 -#define STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING -#define DEFAULT_cfABSOFT2 -#define LOGICAL_cfABSOFT2 -#define STRING_cfABSOFT2 ,unsigned D0 -#define DEFAULT_cfABSOFT3 -#define LOGICAL_cfABSOFT3 -#define STRING_cfABSOFT3 ,D0 -#else -#define ABSOFT_cf1(T0) -#define ABSOFT_cf2(T0) -#define ABSOFT_cf3(T0) -#endif - -/* _Z introduced to cicumvent IBM and HP silly preprocessor warning. - e.g. "Macro CFARGT14 invoked with a null argument." - */ -#define _Z - -#define CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) -#define CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \ - S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \ - S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27) - -#define CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \ - F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \ - M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - -#if !(defined(PowerStationFortran)||defined(hpuxFortran800)) -/* Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields: - SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c - "c.c", line 406: warning: argument mismatch - Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok. - Behavior is most clearly seen in example: - #define A 1 , 2 - #define C(X,Y,Z) x=X. y=Y. z=Z. - #define D(X,Y,Z) C(X,Y,Z) - D(x,A,z) - Output from preprocessor is: x = x . y = 1 . z = 2 . - #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -*/ -#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \ - F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \ - M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - -#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \ - S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) -#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \ - S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \ - S(TB,11) S(TC,12) S(TD,13) S(TE,14) -#if MAX_PREPRO_ARGS>31 -#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \ - F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \ - S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \ - S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) S(TG,16) \ - S(TH,17) S(TI,18) S(TJ,19) S(TK,20) -#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \ - F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \ - F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1) S(T2,2) S(T3,3) \ - S(T4,4) S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) \ - S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) \ - S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \ - S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27) -#endif -#else -#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) -#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \ - F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \ - F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \ - F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27) - -#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \ - F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) -#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) -#if MAX_PREPRO_ARGS>31 -#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \ - F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \ - F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) -#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \ - F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \ - F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) F(TL,AL,21,1) S(TL,21) \ - F(TM,AM,22,1) S(TM,22) F(TN,AN,23,1) S(TN,23) F(TO,AO,24,1) S(TO,24) \ - F(TP,AP,25,1) S(TP,25) F(TQ,AQ,26,1) S(TQ,26) F(TR,AR,27,1) S(TR,27) -#endif -#endif - - -#define PROTOCCALLSFSUB1( UN,LN,T1) \ - PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - - -#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0) -#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0) - -#define PROTOCCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0) -#define PROTOCCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0) - - -#ifndef FCALLSC_QUALIFIER -#ifdef VISUAL_CPLUSPLUS -#define FCALLSC_QUALIFIER __stdcall -#else -#define FCALLSC_QUALIFIER -#endif -#endif - -#ifdef __cplusplus -#define CFextern extern "C" -#else -#define CFextern extern -#endif - - -#ifdef CFSUBASFUN -#define PROTOCCALLSFSUB0(UN,LN) \ - PROTOCCALLSFFUN0( VOID,UN,LN) -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\ - PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\ - PROTOCCALLSFFUN27(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#else -/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after - #include-ing cfortran.h if calling the FORTRAN wrapper within the same - source code where the wrapper is created. */ -#define PROTOCCALLSFSUB0(UN,LN) _(VOID,_cfPU)(CFC_(UN,LN))(); -#ifndef __CF__KnR -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ); -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT20(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) ); -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT27(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ); -#else -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFSUB0(UN,LN) -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - PROTOCCALLSFSUB0(UN,LN) -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - PROTOCCALLSFSUB0(UN,LN) -#endif -#endif - - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - - -#define CCALLSFSUB1( UN,LN,T1, A1) \ - CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0) -#define CCALLSFSUB2( UN,LN,T1,T2, A1,A2) \ - CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0) -#define CCALLSFSUB3( UN,LN,T1,T2,T3, A1,A2,A3) \ - CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0) -#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\ - CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0) -#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0) -#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0) -#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0) -#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0) -#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0) -#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0) -#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0) -#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0) -#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0) - -#ifdef __cplusplus -#define CPPPROTOCLSFSUB0( UN,LN) -#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#else -#define CPPPROTOCLSFSUB0(UN,LN) \ - PROTOCCALLSFSUB0(UN,LN) -#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#endif - -#ifdef CFSUBASFUN -#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN) -#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) -#else -/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */ -#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0) -#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) \ - CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) \ - ACF(LN,T4,A4,4) ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) \ - ACF(LN,T8,A8,8) ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) \ - ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) \ - CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) \ - WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14) }while(0) -#endif - - -#if MAX_PREPRO_ARGS>31 -#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0) -#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0) -#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0) -#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0) -#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0) - -#ifdef CFSUBASFUN -#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) -#else -#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \ - VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \ - CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \ - ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \ - ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \ - ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \ - ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \ - CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \ - WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \ - WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \ - WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0) -#endif -#endif /* MAX_PREPRO_ARGS */ - -#if MAX_PREPRO_ARGS>31 -#define CCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,0,0,0,0,0,0) -#define CCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,0,0,0,0,0) -#define CCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,0,0,0,0) -#define CCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,0,0,0) -#define CCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,0,0) -#define CCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,0) - -#ifdef CFSUBASFUN -#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - CCALLSFFUN27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) -#else -#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \ - VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \ - VVCF(TL,AL,B21) VVCF(TM,AM,B22) VVCF(TN,AN,B23) VVCF(TO,AO,B24) VVCF(TP,AP,B25) \ - VVCF(TQ,AQ,B26) VVCF(TR,AR,B27) \ - CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \ - ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \ - ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \ - ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \ - ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \ - ACF(LN,TL,AL,21) ACF(LN,TM,AM,22) ACF(LN,TN,AN,23) ACF(LN,TO,AO,24) \ - ACF(LN,TP,AP,25) ACF(LN,TQ,AQ,26) ACF(LN,TR,AR,27) \ - CFC_(UN,LN)( CFARGTA27(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,\ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) ); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \ - WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \ - WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \ - WCF(TJ,AJ,19) WCF(TK,AK,20) WCF(TL,AL,21) WCF(TM,AM,22) WCF(TN,AN,23) WCF(TO,AO,24) \ - WCF(TP,AP,25) WCF(TQ,AQ,26) WCF(TR,AR,27) }while(0) -#endif -#endif /* MAX_PREPRO_ARGS */ - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */ - -/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN - function is called. Therefore, especially for creator's of C header files - for large FORTRAN libraries which include many functions, to reduce - compile time and object code size, it may be desirable to create - preprocessor directives to allow users to create code for only those - functions which they use. */ - -/* The following defines the maximum length string that a function can return. - Of course it may be undefine-d and re-define-d before individual - PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived - from the individual machines' limits. */ -#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE - -/* The following defines a character used by CFORTRAN.H to flag the end of a - string coming out of a FORTRAN routine. */ -#define CFORTRAN_NON_CHAR 0x7F - -#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */ -#pragma nostandard -#endif - -#define _SEP_(TN,C,cfCOMMA) _(__SEP_,C)(TN,cfCOMMA) -#define __SEP_0(TN,cfCOMMA) -#define __SEP_1(TN,cfCOMMA) _Icf(2,SEP,TN,cfCOMMA,0) -#define INT_cfSEP(T,B) _(A,B) -#define INTV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define PINT_cfSEP(T,B) INT_cfSEP(T,B) -#define PVOID_cfSEP(T,B) INT_cfSEP(T,B) -#define ROUTINE_cfSEP(T,B) INT_cfSEP(T,B) -#define SIMPLE_cfSEP(T,B) INT_cfSEP(T,B) -#define VOID_cfSEP(T,B) INT_cfSEP(T,B) /* For FORTRAN calls C subr.s.*/ -#define STRING_cfSEP(T,B) INT_cfSEP(T,B) -#define STRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PNSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define PPSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B) - -#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE) -#ifdef OLD_VAXC -#define INTEGER_BYTE char /* Old VAXC barfs on 'signed char' */ -#else -#define INTEGER_BYTE signed char /* default */ -#endif -#else -#define INTEGER_BYTE unsigned char -#endif -#define BYTEVVVVVVV_cfTYPE INTEGER_BYTE -#define DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION -#define FLOATVVVVVVV_cfTYPE FORTRAN_REAL -#define INTVVVVVVV_cfTYPE int -#define LOGICALVVVVVVV_cfTYPE int -#define LONGVVVVVVV_cfTYPE long -#define SHORTVVVVVVV_cfTYPE short -#define PBYTE_cfTYPE INTEGER_BYTE -#define PDOUBLE_cfTYPE DOUBLE_PRECISION -#define PFLOAT_cfTYPE FORTRAN_REAL -#define PINT_cfTYPE int -#define PLOGICAL_cfTYPE int -#define PLONG_cfTYPE long -#define PSHORT_cfTYPE short - -#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A) -#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V) -#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W) -#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X) -#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y) -#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z) - -#define _Icf(N,T,I,X,Y) _(I,_cfINT)(N,T,I,X,Y,0) -#define _Icf4(N,T,I,X,Y,Z) _(I,_cfINT)(N,T,I,X,Y,Z) -#define BYTE_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0) -#define FLOAT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define INT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define LOGICAL_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define LONG_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define SHORT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define PBYTE_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0) -#define PFLOAT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PINT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PLOGICAL_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PLONG_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PSHORT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define BYTEV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define BYTEVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0) -#define DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0) -#define DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0) -#define DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0) -#define FLOATV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define FLOATVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define INTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define INTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define LONGVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define SHORTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0) -#define ROUTINE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -/*CRAY coughs on the first, - i.e. the usual trouble of not being able to - define macros to macros with arguments. - New ultrix is worse, it coughs on all such uses. - */ -/*#define SIMPLE_cfINT PVOID_cfINT*/ -#define SIMPLE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define VOID_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define STRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define STRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PSTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PNSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PPSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define ZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define CF_0_cfINT(N,A,B,X,Y,Z) - - -#define UCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0) -#define UUCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I) -#define UUUCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0) -#define INT_cfU(T,A) _(T,VVVVVVV_cfTYPE) A -#define INTV_cfU(T,A) _(T,VVVVVV_cfTYPE) * A -#define INTVV_cfU(T,A) _(T,VVVVV_cfTYPE) * A -#define INTVVV_cfU(T,A) _(T,VVVV_cfTYPE) * A -#define INTVVVV_cfU(T,A) _(T,VVV_cfTYPE) * A -#define INTVVVVV_cfU(T,A) _(T,VV_cfTYPE) * A -#define INTVVVVVV_cfU(T,A) _(T,V_cfTYPE) * A -#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE) * A -#define PINT_cfU(T,A) _(T,_cfTYPE) * A -#define PVOID_cfU(T,A) void *A -#define ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO) -#define VOID_cfU(T,A) void A /* Needed for C calls FORTRAN sub.s. */ -#define STRING_cfU(T,A) char *A /* via VOID and wrapper. */ -#define STRINGV_cfU(T,A) char *A -#define PSTRING_cfU(T,A) char *A -#define PSTRINGV_cfU(T,A) char *A -#define ZTRINGV_cfU(T,A) char *A -#define PZTRINGV_cfU(T,A) char *A - -/* VOID breaks U into U and UU. */ -#define INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A -#define VOID_cfUU(T,A) /* Needed for FORTRAN calls C sub.s. */ -#define STRING_cfUU(T,A) char *A - - -#define BYTE_cfPU(A) CFextern INTEGER_BYTE FCALLSC_QUALIFIER A -#define DOUBLE_cfPU(A) CFextern DOUBLE_PRECISION FCALLSC_QUALIFIER A -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfPU(A) CFextern FORTRAN_REAL FCALLSC_QUALIFIER A -#else -#define FLOAT_cfPU(A) CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A -#endif -#define INT_cfPU(A) CFextern int FCALLSC_QUALIFIER A -#define LOGICAL_cfPU(A) CFextern int FCALLSC_QUALIFIER A -#define LONG_cfPU(A) CFextern long FCALLSC_QUALIFIER A -#define SHORT_cfPU(A) CFextern short FCALLSC_QUALIFIER A -#define STRING_cfPU(A) CFextern void FCALLSC_QUALIFIER A -#define VOID_cfPU(A) CFextern void FCALLSC_QUALIFIER A - -#define BYTE_cfE INTEGER_BYTE A0; -#define DOUBLE_cfE DOUBLE_PRECISION A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfE FORTRAN_REAL A0; -#else -#define FLOAT_cfE FORTRAN_REAL AA0; FLOATFUNCTIONTYPE A0; -#endif -#define INT_cfE int A0; -#define LOGICAL_cfE int A0; -#define LONG_cfE long A0; -#define SHORT_cfE short A0; -#define VOID_cfE -#ifdef vmsFortran -#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - static fstring A0 = \ - {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\ - memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\ - *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0'; -#else -#ifdef CRAYFortran -#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\ - memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\ - A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING); -#else -/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1]; - * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK. */ -#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - memset(A0, CFORTRAN_NON_CHAR, \ - MAX_LEN_FORTRAN_FUNCTION_STRING); \ - *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0'; -#endif -#endif -/* ESTRING must use static char. array which is guaranteed to exist after - function returns. */ - -/* N.B.i) The diff. for 0 (Zero) and >=1 arguments. - ii)That the following create an unmatched bracket, i.e. '(', which - must of course be matched in the call. - iii)Commas must be handled very carefully */ -#define INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)( -#define VOID_cfGZ(T,UN,LN) CFC_(UN,LN)( -#ifdef vmsFortran -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)(&A0 -#else -#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0 -#else -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING -#endif -#endif - -#define INT_cfG(T,UN,LN) INT_cfGZ(T,UN,LN) -#define VOID_cfG(T,UN,LN) VOID_cfGZ(T,UN,LN) -#define STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/ - -#define BYTEVVVVVVV_cfPP -#define INTVVVVVVV_cfPP /* These complement FLOATVVVVVVV_cfPP. */ -#define DOUBLEVVVVVVV_cfPP -#define LOGICALVVVVVVV_cfPP -#define LONGVVVVVVV_cfPP -#define SHORTVVVVVVV_cfPP -#define PBYTE_cfPP -#define PINT_cfPP -#define PDOUBLE_cfPP -#define PLOGICAL_cfPP -#define PLONG_cfPP -#define PSHORT_cfPP -#define PFLOAT_cfPP FLOATVVVVVVV_cfPP - -#define BCF(TN,AN,C) _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0) -#define INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A -#define INTV_cfB(T,A) A -#define INTVV_cfB(T,A) (A)[0] -#define INTVVV_cfB(T,A) (A)[0][0] -#define INTVVVV_cfB(T,A) (A)[0][0][0] -#define INTVVVVV_cfB(T,A) (A)[0][0][0][0] -#define INTVVVVVV_cfB(T,A) (A)[0][0][0][0][0] -#define INTVVVVVVV_cfB(T,A) (A)[0][0][0][0][0][0] -#define PINT_cfB(T,A) _(T,_cfPP)&A -#define STRING_cfB(T,A) (char *) A -#define STRINGV_cfB(T,A) (char *) A -#define PSTRING_cfB(T,A) (char *) A -#define PSTRINGV_cfB(T,A) (char *) A -#define PVOID_cfB(T,A) (void *) A -#define ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A -#define ZTRINGV_cfB(T,A) (char *) A -#define PZTRINGV_cfB(T,A) (char *) A - -#define SCF(TN,NAME,I,A) _(TN,_cfSTR)(3,S,NAME,I,A,0,0) -#define DEFAULT_cfS(M,I,A) -#define LOGICAL_cfS(M,I,A) -#define PLOGICAL_cfS(M,I,A) -#define STRING_cfS(M,I,A) ,sizeof(A) -#define STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \ - +secondindexlength(A)) -#define PSTRING_cfS(M,I,A) ,sizeof(A) -#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A) -#define ZTRINGV_cfS(M,I,A) -#define PZTRINGV_cfS(M,I,A) - -#define HCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0) -#define HHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0) -#define HHHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0) -#define H_CF_SPECIAL unsigned -#define HH_CF_SPECIAL -#define DEFAULT_cfH(M,I,A) -#define LOGICAL_cfH(S,U,B) -#define PLOGICAL_cfH(S,U,B) -#define STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B -#define STRINGV_cfH(S,U,B) STRING_cfH(S,U,B) -#define PSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B) -#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define ZTRINGV_cfH(S,U,B) -#define PZTRINGV_cfH(S,U,B) - -/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */ -/* No spaces inside expansion. They screws up macro catenation kludge. */ -#define VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E) -#define LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E) -#define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E) -#define PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E) -#define STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E) -#define PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E) -#define PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E) -#define PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E) -#define PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E) -#define PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E) -#define CF_0_cfSTR(N,T,A,B,C,D,E) - -/* See ACF table comments, which explain why CCF was split into two. */ -#define CCF(NAME,TN,I) _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I)) -#define DEFAULT_cfC(M,I,A,B,C) -#define LOGICAL_cfC(M,I,A,B,C) A=C2FLOGICAL( A); -#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A); -#ifdef vmsFortran -#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A, \ - C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen: \ - (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0')); - /* PSTRING_cfC to beware of array A which does not contain any \0. */ -#define PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ? \ - B.dsc$w_length=strlen(A): (A[C-1]='\0',B.dsc$w_length=strlen(A), \ - memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1)); -#else -#define STRING_cfC(M,I,A,B,C) (B.nombre=A,B.clen=strlen(A), \ - C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen: \ - (memset(B.nombre+B.clen,' ',C-B.clen-1),B.nombre[B.flen=C-1]='\0')); -#define PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A): \ - (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1)); -#endif - /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */ -#define STRINGV_cfC(M,I,A,B,C) \ - AATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF) -#define PSTRINGV_cfC(M,I,A,B,C) \ - APATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF) -#define ZTRINGV_cfC(M,I,A,B,C) \ - AATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \ - (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 ) -#define PZTRINGV_cfC(M,I,A,B,C) \ - APATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \ - (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 ) - -#define BYTE_cfCCC(A,B) &A -#define DOUBLE_cfCCC(A,B) &A -#if !defined(__CF__KnR) -#define FLOAT_cfCCC(A,B) &A - /* Although the VAX doesn't, at least the */ -#else /* HP and K&R mips promote float arg.'s of */ -#define FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot */ -#endif /* use A here to pass the argument to FORTRAN. */ -#define INT_cfCCC(A,B) &A -#define LOGICAL_cfCCC(A,B) &A -#define LONG_cfCCC(A,B) &A -#define SHORT_cfCCC(A,B) &A -#define PBYTE_cfCCC(A,B) A -#define PDOUBLE_cfCCC(A,B) A -#define PFLOAT_cfCCC(A,B) A -#define PINT_cfCCC(A,B) A -#define PLOGICAL_cfCCC(A,B) B=A /* B used to keep a common W table. */ -#define PLONG_cfCCC(A,B) A -#define PSHORT_cfCCC(A,B) A - -#define CCCF(TN,I,M) _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I)) -#define INT_cfCC(T,A,B) _(T,_cfCCC)(A,B) -#define INTV_cfCC(T,A,B) A -#define INTVV_cfCC(T,A,B) A -#define INTVVV_cfCC(T,A,B) A -#define INTVVVV_cfCC(T,A,B) A -#define INTVVVVV_cfCC(T,A,B) A -#define INTVVVVVV_cfCC(T,A,B) A -#define INTVVVVVVV_cfCC(T,A,B) A -#define PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B) -#define PVOID_cfCC(T,A,B) A -#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) -#define ROUTINE_cfCC(T,A,B) &A -#else -#define ROUTINE_cfCC(T,A,B) A -#endif -#define SIMPLE_cfCC(T,A,B) A -#ifdef vmsFortran -#define STRING_cfCC(T,A,B) &B.f -#define STRINGV_cfCC(T,A,B) &B -#define PSTRING_cfCC(T,A,B) &B -#define PSTRINGV_cfCC(T,A,B) &B -#else -#ifdef CRAYFortran -#define STRING_cfCC(T,A,B) _cptofcd(A,B.flen) -#define STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen) -#define PSTRING_cfCC(T,A,B) _cptofcd(A,B) -#define PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen) -#else -#define STRING_cfCC(T,A,B) A -#define STRINGV_cfCC(T,A,B) B.fs -#define PSTRING_cfCC(T,A,B) A -#define PSTRINGV_cfCC(T,A,B) B.fs -#endif -#endif -#define ZTRINGV_cfCC(T,A,B) STRINGV_cfCC(T,A,B) -#define PZTRINGV_cfCC(T,A,B) PSTRINGV_cfCC(T,A,B) - -#define BYTE_cfX return A0; -#define DOUBLE_cfX return A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfX return A0; -#else -#define FLOAT_cfX ASSIGNFLOAT(AA0,A0); return AA0; -#endif -#define INT_cfX return A0; -#define LOGICAL_cfX return F2CLOGICAL(A0); -#define LONG_cfX return A0; -#define SHORT_cfX return A0; -#define VOID_cfX return ; -#if defined(vmsFortran) || defined(CRAYFortran) -#define STRING_cfX return kill_trailing( \ - kill_trailing(AA0,CFORTRAN_NON_CHAR),' '); -#else -#define STRING_cfX return kill_trailing( \ - kill_trailing( A0,CFORTRAN_NON_CHAR),' '); -#endif - -#define CFFUN(NAME) _(__cf__,NAME) - -/* Note that we don't use LN here, but we keep it for consistency. */ -#define CCALLSFFUN0(UN,LN) CFFUN(UN)() - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define CCALLSFFUN1( UN,LN,T1, A1) \ - CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0) -#define CCALLSFFUN2( UN,LN,T1,T2, A1,A2) \ - CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0) -#define CCALLSFFUN3( UN,LN,T1,T2,T3, A1,A2,A3) \ - CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0) -#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\ - CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0) -#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0) -#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0) -#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0) -#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0) -#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0) -#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0) -#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0) -#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0) -#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0) - -#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ -((CFFUN(UN)( BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \ - BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \ - BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1) \ - SCF(T1,LN,1,A1) SCF(T2,LN,2,A2) SCF(T3,LN,3,A3) SCF(T4,LN,4,A4) \ - SCF(T5,LN,5,A5) SCF(T6,LN,6,A6) SCF(T7,LN,7,A7) SCF(T8,LN,8,A8) \ - SCF(T9,LN,9,A9) SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \ - SCF(TD,LN,13,AD) SCF(TE,LN,14,AE)))) - -/* N.B. Create a separate function instead of using (call function, function -value here) because in order to create the variables needed for the input -arg.'s which may be const.'s one has to do the creation within {}, but these -can never be placed within ()'s. Therefore one must create wrapper functions. -gcc, on the other hand may be able to avoid the wrapper functions. */ - -/* Prototypes are needed to correctly handle the value returned correctly. N.B. -Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN -functions returning strings have extra arg.'s. Don't bother, since this only -causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn -for the same function in the same source code. Something done by the experts in -debugging only.*/ - -#define PROTOCCALLSFFUN0(F,UN,LN) \ -_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO); \ -static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)} - -#define PROTOCCALLSFFUN1( T0,UN,LN,T1) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0) -#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0) -#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0) -#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0) -#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - -/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */ - -#ifndef __CF__KnR -#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \ - CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ -{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \ - CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \ - CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \ - CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \ - CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \ - WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)} -#else -#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \ - CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ - CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ; \ -{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \ - CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \ - CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \ - CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \ - CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \ - WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)} -#endif - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */ - -#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */ -#pragma nostandard -#endif - -#if defined(vmsFortran) || defined(CRAYFortran) -#define DCF(TN,I) -#define DDCF(TN,I) -#define DDDCF(TN,I) -#else -#define DCF(TN,I) HCF(TN,I) -#define DDCF(TN,I) HHCF(TN,I) -#define DDDCF(TN,I) HHHCF(TN,I) -#endif - -#define QCF(TN,I) _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0) -#define DEFAULT_cfQ(B) -#define LOGICAL_cfQ(B) -#define PLOGICAL_cfQ(B) -#define STRINGV_cfQ(B) char *B; unsigned int _(B,N); -#define STRING_cfQ(B) char *B=NULL; -#define PSTRING_cfQ(B) char *B=NULL; -#define PSTRINGV_cfQ(B) STRINGV_cfQ(B) -#define PNSTRING_cfQ(B) char *B=NULL; -#define PPSTRING_cfQ(B) - -#ifdef __sgi /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */ -#define ROUTINE_orig *(void**)& -#else -#define ROUTINE_orig (void *) -#endif - -#define ROUTINE_1 ROUTINE_orig -#define ROUTINE_2 ROUTINE_orig -#define ROUTINE_3 ROUTINE_orig -#define ROUTINE_4 ROUTINE_orig -#define ROUTINE_5 ROUTINE_orig -#define ROUTINE_6 ROUTINE_orig -#define ROUTINE_7 ROUTINE_orig -#define ROUTINE_8 ROUTINE_orig -#define ROUTINE_9 ROUTINE_orig -#define ROUTINE_10 ROUTINE_orig -#define ROUTINE_11 ROUTINE_orig -#define ROUTINE_12 ROUTINE_orig -#define ROUTINE_13 ROUTINE_orig -#define ROUTINE_14 ROUTINE_orig -#define ROUTINE_15 ROUTINE_orig -#define ROUTINE_16 ROUTINE_orig -#define ROUTINE_17 ROUTINE_orig -#define ROUTINE_18 ROUTINE_orig -#define ROUTINE_19 ROUTINE_orig -#define ROUTINE_20 ROUTINE_orig -#define ROUTINE_21 ROUTINE_orig -#define ROUTINE_22 ROUTINE_orig -#define ROUTINE_23 ROUTINE_orig -#define ROUTINE_24 ROUTINE_orig -#define ROUTINE_25 ROUTINE_orig -#define ROUTINE_26 ROUTINE_orig -#define ROUTINE_27 ROUTINE_orig - -#define TCF(NAME,TN,I,M) _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I)) -#define BYTE_cfT(M,I,A,B,D) *A -#define DOUBLE_cfT(M,I,A,B,D) *A -#define FLOAT_cfT(M,I,A,B,D) *A -#define INT_cfT(M,I,A,B,D) *A -#define LOGICAL_cfT(M,I,A,B,D) F2CLOGICAL(*A) -#define LONG_cfT(M,I,A,B,D) *A -#define SHORT_cfT(M,I,A,B,D) *A -#define BYTEV_cfT(M,I,A,B,D) A -#define DOUBLEV_cfT(M,I,A,B,D) A -#define FLOATV_cfT(M,I,A,B,D) VOIDP A -#define INTV_cfT(M,I,A,B,D) A -#define LOGICALV_cfT(M,I,A,B,D) A -#define LONGV_cfT(M,I,A,B,D) A -#define SHORTV_cfT(M,I,A,B,D) A -#define BYTEVV_cfT(M,I,A,B,D) (void *)A /* We have to cast to void *,*/ -#define BYTEVVV_cfT(M,I,A,B,D) (void *)A /* since we don't know the */ -#define BYTEVVVV_cfT(M,I,A,B,D) (void *)A /* dimensions of the array. */ -#define BYTEVVVVV_cfT(M,I,A,B,D) (void *)A /* i.e. Unfortunately, can't */ -#define BYTEVVVVVV_cfT(M,I,A,B,D) (void *)A /* check that the type */ -#define BYTEVVVVVVV_cfT(M,I,A,B,D) (void *)A /* matches the prototype. */ -#define DOUBLEVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVV_cfT(M,I,A,B,D) (void *)A -#define INTVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define PBYTE_cfT(M,I,A,B,D) A -#define PDOUBLE_cfT(M,I,A,B,D) A -#define PFLOAT_cfT(M,I,A,B,D) VOIDP A -#define PINT_cfT(M,I,A,B,D) A -#define PLOGICAL_cfT(M,I,A,B,D) ((*A=F2CLOGICAL(*A)),A) -#define PLONG_cfT(M,I,A,B,D) A -#define PSHORT_cfT(M,I,A,B,D) A -#define PVOID_cfT(M,I,A,B,D) A -#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) -#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) (*A) -#else -#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) A -#endif -/* A == pointer to the characters - D == length of the string, or of an element in an array of strings - E == number of elements in an array of strings */ -#define TTSTR( A,B,D) \ - ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' ')) -#define TTTTSTR( A,B,D) (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL: \ - memchr(A,'\0',D) ?A : TTSTR(A,B,D) -#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *) \ - vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' ')) -#ifdef vmsFortran -#define STRING_cfT(M,I,A,B,D) TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \ - A->dsc$w_length , A->dsc$l_m[0]) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define PPSTRING_cfT(M,I,A,B,D) A->dsc$a_pointer -#else -#ifdef CRAYFortran -#define STRING_cfT(M,I,A,B,D) TTTTSTR( _fcdtocp(A),B,_fcdlen(A)) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(_fcdtocp(A),B,_fcdlen(A), \ - num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I))) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( _fcdtocp(A),B,_fcdlen(A)) -#define PPSTRING_cfT(M,I,A,B,D) _fcdtocp(A) -#else -#define STRING_cfT(M,I,A,B,D) TTTTSTR( A,B,D) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I))) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( A,B,D) -#define PPSTRING_cfT(M,I,A,B,D) A -#endif -#endif -#define PNSTRING_cfT(M,I,A,B,D) STRING_cfT(M,I,A,B,D) -#define PSTRINGV_cfT(M,I,A,B,D) STRINGV_cfT(M,I,A,B,D) -#define CF_0_cfT(M,I,A,B,D) - -#define RCF(TN,I) _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0) -#define DEFAULT_cfR(A,B,D) -#define LOGICAL_cfR(A,B,D) -#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A); -#define STRING_cfR(A,B,D) if (B) _cf_free(B); -#define STRINGV_cfR(A,B,D) _cf_free(B); -/* A and D as defined above for TSTRING(V) */ -#define RRRRPSTR( A,B,D) if (B) memcpy(A,B, _cfMIN(strlen(B),D)), \ - (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B); -#define RRRRPSTRV(A,B,D) c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B); -#ifdef vmsFortran -#define PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length) -#else -#ifdef CRAYFortran -#define PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A)) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A)) -#else -#define PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D) -#endif -#endif -#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D) -#define PPSTRING_cfR(A,B,D) - -#define BYTE_cfFZ(UN,LN) INTEGER_BYTE FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define INT_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define LOGICAL_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define LONG_cfFZ(UN,LN) long FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define VOID_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)( -#ifndef __CF__KnR -/* The void is req'd by the Apollo, to make this an ANSI function declaration. - The Apollo promotes K&R float functions to double. */ -#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void -#ifdef vmsFortran -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS -#else -#ifdef CRAYFortran -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd AS -#else -#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS -#else -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS, unsigned D0 -#endif -#endif -#endif -#else -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)( -#else -#define FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)( -#endif -#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran) -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS -#else -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0 -#endif -#endif - -#define BYTE_cfF(UN,LN) BYTE_cfFZ(UN,LN) -#define DOUBLE_cfF(UN,LN) DOUBLE_cfFZ(UN,LN) -#ifndef __CF_KnR -#define FLOAT_cfF(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)( -#else -#define FLOAT_cfF(UN,LN) FLOAT_cfFZ(UN,LN) -#endif -#define INT_cfF(UN,LN) INT_cfFZ(UN,LN) -#define LOGICAL_cfF(UN,LN) LOGICAL_cfFZ(UN,LN) -#define LONG_cfF(UN,LN) LONG_cfFZ(UN,LN) -#define SHORT_cfF(UN,LN) SHORT_cfFZ(UN,LN) -#define VOID_cfF(UN,LN) VOID_cfFZ(UN,LN) -#define STRING_cfF(UN,LN) STRING_cfFZ(UN,LN), - -#define INT_cfFF -#define VOID_cfFF -#ifdef vmsFortran -#define STRING_cfFF fstring *AS; -#else -#ifdef CRAYFortran -#define STRING_cfFF _fcd AS; -#else -#define STRING_cfFF char *AS; unsigned D0; -#endif -#endif - -#define INT_cfL A0= -#define STRING_cfL A0= -#define VOID_cfL - -#define INT_cfK -#define VOID_cfK -/* KSTRING copies the string into the position provided by the caller. */ -#ifdef vmsFortran -#define STRING_cfK \ - memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\ - AS->dsc$w_length>(A0==NULL?0:strlen(A0))? \ - memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ', \ - AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0; -#else -#ifdef CRAYFortran -#define STRING_cfK \ - memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) ); \ - _fcdlen(AS)>(A0==NULL?0:strlen(A0))? \ - memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ', \ - _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0; -#else -#define STRING_cfK memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \ - D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \ - ' ', D0-(A0==NULL?0:strlen(A0))):0; -#endif -#endif - -/* Note that K.. and I.. can't be combined since K.. has to access data before -R.., in order for functions returning strings which are also passed in as -arguments to work correctly. Note that R.. frees and hence may corrupt the -string. */ -#define BYTE_cfI return A0; -#define DOUBLE_cfI return A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfI return A0; -#else -#define FLOAT_cfI RETURNFLOAT(A0); -#endif -#define INT_cfI return A0; -#ifdef hpuxFortran800 -/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */ -#define LOGICAL_cfI return ((A0)?1:0); -#else -#define LOGICAL_cfI return C2FLOGICAL(A0); -#endif -#define LONG_cfI return A0; -#define SHORT_cfI return A0; -#define STRING_cfI return ; -#define VOID_cfI return ; - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define FCALLSCSUB0( CN,UN,LN) FCALLSCFUN0(VOID,CN,UN,LN) -#define FCALLSCSUB1( CN,UN,LN,T1) FCALLSCFUN1(VOID,CN,UN,LN,T1) -#define FCALLSCSUB2( CN,UN,LN,T1,T2) FCALLSCFUN2(VOID,CN,UN,LN,T1,T2) -#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3) FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3) -#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \ - FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4) -#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \ - FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5) -#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \ - FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6) -#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) -#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) -#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) -#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) -#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) -#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) -#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) -#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) -#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) -#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) -#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) -#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) -#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) -#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) -#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) -#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) -#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) -#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) -#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - - -#define FCALLSCFUN1( T0,CN,UN,LN,T1) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0) -#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0) -#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0) -#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0) -#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0) -#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0) -#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - - -#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0) -#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0) -#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0) -#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0) -#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0) -#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0) - - -#ifndef __CF__KnR -#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0)) \ - {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)} - -#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ - { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \ - CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) } - -#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \ - { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \ - TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \ - TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \ - CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI) } - -#else -#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\ - {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)} - -#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \ - CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE); \ - { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \ - CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI)} - -#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \ - CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \ - { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \ - TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \ - TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \ - CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI)} - -#endif - - -#endif /* __CFORTRAN_LOADED */ diff --git a/assim/enkf_cf-system2_old/EnKF/common_eos.h b/assim/enkf_cf-system2_old/EnKF/common_eos.h deleted file mode 100755 index dfe2575a..00000000 --- a/assim/enkf_cf-system2_old/EnKF/common_eos.h +++ /dev/null @@ -1,30 +0,0 @@ -c -c --- common blocks related to the equation of state -c - c o m m o n /eos/ -c -c --- coefficients for the functional fit of in situ density -c - . a11,a12,a13,a14,a15,a16,b11,b12,b13 - .,a21,a22,a23,a24,a25,a26,b21,b22,b23 -c -c --- reference pressure - .,pref -c -c --- coefficients for potential density in sigma units with reference -c --- pressure at -pref- - .,ap11,ap12,ap13,ap14,ap15,ap16 - .,ap21,ap22,ap23,ap24,ap25,ap26 -c -c --- coefficients for potential density in sigma units with reference -c --- pressure at the surface - .,ap110,ap120,ap130,ap140,ap150,ap160 - .,ap210,ap220,ap230,ap240,ap250,ap260 -c - real a11,a12,a13,a14,a15,a16,b11,b12,b13 - . ,a21,a22,a23,a24,a25,a26,b21,b22,b23 - . ,pref - . ,ap11,ap12,ap13,ap14,ap15,ap16 - . ,ap21,ap22,ap23,ap24,ap25,ap26 - . ,ap110,ap120,ap130,ap140,ap150,ap160 - . ,ap210,ap220,ap230,ap240,ap250,ap260 diff --git a/assim/enkf_cf-system2_old/EnKF/distribute.F90 b/assim/enkf_cf-system2_old/EnKF/distribute.F90 deleted file mode 100755 index c21950c3..00000000 --- a/assim/enkf_cf-system2_old/EnKF/distribute.F90 +++ /dev/null @@ -1,245 +0,0 @@ -module distribute - -#if defined(QMPI) - use qmpi -#else - use qmpi_fake -#endif - - ! - ! public stuff - ! - integer, public :: my_number_of_iterations, my_first_iteration, my_last_iteration - integer, dimension(:), allocatable, public :: number_of_iterations, first_iteration, last_iteration - integer, dimension(:), allocatable, public :: randommap - -contains - subroutine distribute_iterations(nz) - implicit none - - integer, intent(in) :: nz - - integer :: i, j - real(8) :: num_procs_real, mean_iterations - - if (.not. allocated(number_of_iterations)) then - allocate(number_of_iterations(qmpi_num_proc)) - end if - if (.not. allocated(first_iteration)) then - allocate(first_iteration(qmpi_num_proc)) - end if - if (.not. allocated(last_iteration)) then - allocate(last_iteration(qmpi_num_proc)) - end if - - if (master) then - print *, 'Distribution of iterations:' - end if - - num_procs_real = qmpi_num_proc - mean_iterations = nz / num_procs_real - - j = -1 - if (int(mean_iterations) .eq. mean_iterations) then - my_number_of_iterations = nz/qmpi_num_proc - if (master) then - number_of_iterations(:) = nz / qmpi_num_proc - print *, 'All procs get ', number_of_iterations(1), 'iterations' - endif - j = qmpi_num_proc - else - do i = 1, qmpi_num_proc - if (i * floor(mean_iterations) +& - (qmpi_num_proc-i) * ceiling(mean_iterations) .eq. nz) then - j = i - exit - endif - end do - - if (qmpi_proc_num + 1 .le. j) then - my_number_of_iterations = floor(mean_iterations) - else - my_number_of_iterations = ceiling(mean_iterations) - endif - - if (master) then - number_of_iterations(1:j) = floor(mean_iterations) - number_of_iterations(j+1:qmpi_num_proc) = ceiling(mean_iterations) - if ((j * floor(mean_iterations) +& - (qmpi_num_proc - j) * ceiling(mean_iterations)) .ne. nz) then - print *, 'ERROR in distribute_iteration()' - stop - endif - endif - endif - - if (master) then - first_iteration(1) = 1; - last_iteration(1) = number_of_iterations(1) - do i = 2, qmpi_num_proc - first_iteration(i) = last_iteration(i - 1) + 1 - last_iteration(i) = first_iteration(i) + number_of_iterations(i) - 1 - end do - endif - - if (qmpi_proc_num + 1 .le. j) then - my_first_iteration = qmpi_proc_num*my_number_of_iterations + 1 - else - my_first_iteration = j * (my_number_of_iterations - 1) +& - (qmpi_proc_num - j) * my_number_of_iterations + 1 - endif - my_last_iteration = my_first_iteration + my_number_of_iterations - 1 - - print *, 'I am', qmpi_proc_num, ', my_first_ind =', my_first_iteration,& - ', my_last_ind =', my_last_iteration - end subroutine distribute_iterations - - subroutine distribute_iterations_field(nz, names, levels) - implicit none - - integer , intent(in) :: nz - character(len=8), dimension(nz), intent(in):: names - integer , dimension(nz), intent(in):: levels - - integer :: i, j1, j2, j3, index_dp, dplen, num_procs_int - real(8) :: num_procs_real - real(8) :: mean_iterations1, mean_iterations2, mean_iterations3 - - if (.not. allocated(number_of_iterations)) then - allocate(number_of_iterations(qmpi_num_proc)) - end if - if (.not. allocated(first_iteration)) then - allocate(first_iteration(qmpi_num_proc)) - end if - if (.not. allocated(last_iteration)) then - allocate(last_iteration(qmpi_num_proc)) - end if - - ! Find the index of field 'dp' for the level 1 - dplen = 0 - do i=1,nz - if (trim(names(i)) .eq. 'dp') dplen = dplen + 1 - end do - if (dplen .eq. 0) then - ! no dp as varibale, just call standard function - call distribute_iterations(nz) - return - else if (qmpi_num_proc .le. 2) then - print *, 'ERROR in distribute_iteration_field():' - print *, 'qmpi_num_proc should be greater than 2' - print *, ' option 1: use more than 2 cpus' - print *, ' option 2: do not update dp' - stop - end if - do i=1,nz - if ((trim(names(i)) .eq. 'dp')) then - index_dp = i - exit - end if - end do - - if (master) then - print *, 'Distribution of iterations:' - end if - - ! All DP take one proc - num_procs_real = (qmpi_num_proc - 1) * (index_dp - 1)& - /(nz-dplen) - num_procs_int = max(int(num_procs_real), 1) - mean_iterations1 = (index_dp - 1) / real(num_procs_int) - mean_iterations2 = dplen - mean_iterations3 = (nz - dplen - (index_dp - 1))& - /real(max(qmpi_num_proc - 1 - num_procs_int, 1)) - - j1 = -1 - do i = 1, num_procs_int - if (i * floor(mean_iterations1) + (num_procs_int - i) & - * ceiling(mean_iterations1) .eq. (index_dp - 1)) then - j1 = i - exit - endif - end do - - j2 = num_procs_int + 1 - - j3 = -1 - do i = j2+1,qmpi_num_proc - if ((i - j2) * floor(mean_iterations3) +& - (qmpi_num_proc - i) * ceiling(mean_iterations3) .eq. & - (nz - dplen - (index_dp - 1))) then - j3 = i - exit - endif - end do - - if (qmpi_proc_num + 1 .le. j1) then - my_number_of_iterations = floor(mean_iterations1) - else if (qmpi_proc_num + 1 .lt. j2) then - my_number_of_iterations = ceiling(mean_iterations1) - else if (qmpi_proc_num + 1 .eq. j2) then - my_number_of_iterations = nint(mean_iterations2) - else if (qmpi_proc_num + 1 .le. j3) then - my_number_of_iterations = floor(mean_iterations3) - else - my_number_of_iterations = ceiling(mean_iterations3) - endif - - if (master) then - number_of_iterations(1:j1) = floor(mean_iterations1) - number_of_iterations(j1+1:j2-1) = ceiling(mean_iterations1) - number_of_iterations(j2) = nint(mean_iterations2) - number_of_iterations(j2+1:j3) = floor(mean_iterations3) - number_of_iterations(j3+1:qmpi_num_proc) = floor(mean_iterations3) - if ((j1 * floor(mean_iterations1) + (j2 - 1 - j1) * & - ceiling(mean_iterations1)) .ne. index_dp-1) then - print *, j1, floor(mean_iterations1), ceiling(mean_iterations1), j2 - print *, 'ERROR in distribute_iteration_field for j1' - stop - endif - if (((j3 - j2) * floor(mean_iterations3) + (qmpi_num_proc - j3) *& - ceiling(mean_iterations3)) .ne. (nz - dplen - (index_dp - 1))) then - print *, 'ERROR in distribute_iteration_field for j3' - stop - endif - if ((j1 * floor(mean_iterations1) +& - (j2 - 1 - j1) * ceiling(mean_iterations1) +& - nint(mean_iterations2) + & - (j3 - j2) * floor(mean_iterations3) +& - (qmpi_num_proc - j3) * ceiling(mean_iterations3)) .ne. nz) then - print *, 'ERROR in distribute_iteration_field for j2' - stop - endif - endif - - if (master) then - first_iteration(1) = 1; - last_iteration(1) = number_of_iterations(1) - do i = 2, qmpi_num_proc - first_iteration(i) = last_iteration(i - 1) + 1 - last_iteration(i) = first_iteration(i) + number_of_iterations(i) - 1 - end do - endif - - if (qmpi_proc_num + 1 .le. j1) then - my_first_iteration = qmpi_proc_num*my_number_of_iterations + 1 - else if (qmpi_proc_num + 1 .lt. j2) then - my_first_iteration = j1 * (my_number_of_iterations - 1) +& - (qmpi_proc_num - j1) * my_number_of_iterations + 1 - else if (qmpi_proc_num + 1 .eq. j2) then - my_first_iteration = index_dp - else if (qmpi_proc_num + 1 .le. j3) then - my_first_iteration = index_dp + dplen + (qmpi_proc_num - j2) *& - my_number_of_iterations - else - my_first_iteration = index_dp + dplen + & - (j3 - j2) * (my_number_of_iterations - 1) +& - (qmpi_proc_num - j3) * my_number_of_iterations - endif - my_last_iteration = my_first_iteration + my_number_of_iterations - 1 - - print *, 'I am', qmpi_proc_num, ', my_first_ind =', my_first_iteration,& - ', my_last_ind =', my_last_iteration - end subroutine distribute_iterations_field - -end module distribute - diff --git a/assim/enkf_cf-system2_old/EnKF/eosdat.F b/assim/enkf_cf-system2_old/EnKF/eosdat.F deleted file mode 100755 index 56f140e4..00000000 --- a/assim/enkf_cf-system2_old/EnKF/eosdat.F +++ /dev/null @@ -1,34 +0,0 @@ - block data eosdat -c - implicit none -c -#include "common_eos.h" -c - data -c -c --- coefficients for the functional fit of in situ density -c - . a11/ 9.9985372432159340e-01/ - .,a12/ 1.0380621928183473e-02/ - .,a13/ 1.7073577195684715e-03/ - .,a14/-3.6570490496333680e-05/ - .,a15/-7.3677944503527477e-06/ - .,a16/-3.5529175999643348e-06/ - .,b11/ 1.7083494994335439e-10/ - .,b12/ 7.1567921402953455e-13/ - .,b13/ 1.2821026080049485e-13/ - .,a21/ 1.0 / - .,a22/ 1.0316374535350838e-02/ - .,a23/ 8.9521792365142522e-04/ - .,a24/-2.8438341552142710e-05/ - .,a25/-1.1887778959461776e-05/ - .,a26/-4.0163964812921489e-06/ - .,b21/ 1.1995545126831476e-10/ - .,b22/ 5.5234008384648383e-13/ - .,b23/ 8.4310335919950873e-14/ -c -c --- reference pressure (dyn/cm^2) -c - ,pref/2000.e5/ -c - end diff --git a/assim/enkf_cf-system2_old/EnKF/m_Generate_element_Si.F90 b/assim/enkf_cf-system2_old/EnKF/m_Generate_element_Si.F90 deleted file mode 100755 index 93e218a9..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_Generate_element_Si.F90 +++ /dev/null @@ -1,940 +0,0 @@ -! File: m_Generate_element_Si.F90 -! -! Created: ??? -! -! Last modified: 09/03/2016 -! -! Purpose: Calculation of HA_i ("S_i") -! -! Description: Calculates HA_i for ensmeble memmber i for given data type. -! -! Modifications: -! 09/03/2016 Yiguo WANG: create get_S_spline() that performs -! the piecewise cubic Hermite interpolate for vertical -! interpolation -! 18/03/2016 Yiguo WANG: set SAL_MIN = 1.0, instead of SAL_MIN = 5.0 -! 22/07/2016 Yiguo WANG: create get_climato_spline() for climotological -! model data -! -! - -module m_Generate_element_Si - implicit none - - public Generate_element_Si - public get_S - public get_S_spline - - integer, parameter, private :: NONE = 0 - integer, parameter, private :: TEMPERATURE = 1 - integer, parameter, private :: SALINITY = 2 - - real, parameter, private :: TEM_MIN = -2.5 - real, parameter, private :: TEM_MAX = 35.0 - real, parameter, private :: SAL_MIN = 1.0 - real, parameter, private :: SAL_MAX = 41.0 - - logical, parameter, private :: VERT_INTERP_GRID = .true. - -contains - - subroutine Generate_element_Si(S, obstype, fld, depths, nx, ny, nz, t) - use mod_measurement - use m_obs - implicit none - - real, dimension(nobs), intent(inout) :: S ! input/output vector - character(len=5), intent(in) :: obstype ! the model fld type in "fld" - integer, intent(in) :: nx,ny,nz ! grid size - real, intent(in) :: fld (nx,ny) ! field to be placed in Si - real, intent(in) :: depths(nx,ny) ! depth mask -- needed for support - integer, intent(in), optional :: t !time of fld - - integer :: iobs - integer :: i, j, ip1, jp1 - integer :: ix, jy, imin, imax, jmin, jmax, cnt - - logical :: isprofile - real :: depth - integer :: ns - - real, parameter :: undef = 999.9 ! land points have value huge() - - ! TEM, GTEM, SAL and GSAL come from profiles - isprofile = (trim(obstype) .eq. 'SAL' .or.& - trim(obstype) .eq. 'GSAL' .or.& - trim(obstype) .eq. 'TEM' .or.& - trim(obstype) .eq. 'GTEM') - - do iobs = 1, nobs - if (trim(obstype) == obs(iobs) % id) then - if (trim(obstype) .ne. 'TSLA' .or. obs(iobs) % date == t) then - ! Get model gridcell - i = obs(iobs) % ipiv - j = obs(iobs) % jpiv - ip1 = min(i + 1, nx) - jp1 = min(j + 1, ny) - - depth = obs(iobs) % depth - - !TODO: 1. check consistency for ns = 1 vs ns = 0 - ! 2. check consistency of running from -ns to +ns (this can - ! lead perhaps for averaginf over -1 0 1 = 3 x 3 instead - ! of 2 x 2 grid cells if ns = 1 - if (depth .lt. 10.0 .and. .not. isprofile) then ! satellite data - ns = obs(iobs) % ns - if(ns .lt. 2) then ! point data : zero support - if (fld(i,j)>1000.) print *, 'WTF',i,j,depths(i,j) - S(iobs) = fld(i, j) - else ! data support assumed a square of 2ns * 2ns grid cells - imin = max( 1, i - ns) - imax = min(nx, i + ns) - jmin = max( 1, j - ns) - jmax = min(ny, j + ns) - cnt = 0 - S(iobs) = 0.0 - do jy = jmin, jmax - do ix = imin, imax - if (depths(ix, jy) > 1.0 .and. abs(fld(ix, jy)) < 10.0d3 .and. fld(ix, jy) /= 0.0d0 .and. fld(ix, jy) + 1.0d0 /= fld(ix, jy)) then - S(iobs) = S(iobs) + fld(ix, jy) - cnt = cnt + 1 - endif - enddo - enddo - - if (cnt == 0) then - print *, ' observation on land ', i, j, obs(iobs) % d - stop 'm_Generate_element_Sij: report bug to LB (laurentb@nersc.no)' - end if - S(iobs) = S(iobs) / real(cnt) - endif - - elseif(isprofile) then ! in-situ data (in depth) - print *,'(m_Generate_element_Si does not handle profiles yet)' - stop '(m_Generate_element_Si)' - else - stop 'Generate_element_Sij: not a profile but depth is deeper than 10m' - endif - end if ! obs and model are at similar time - end if ! (trim(obstype) == obs(iobs) % id) then - end do - end subroutine Generate_element_Si - - ! Get S = HA for in-situ data. Linearly interpolate for obs positioned - ! between the layer centres; otherwise use the layer value for the obs above - ! the middle of the first layer or below the middle of the last layer. - ! - ! Note - this procedure parses through all obs for each ensemble member - ! to work out profiles. This indeed invlolves some redundancy because - ! this work could be done only once. However, the penalty (I think) is - ! quite small compared to the time required for reading the fields from - ! files and does not worth modifying (and complicating) the code. - ! - subroutine get_S(S, obstag, nobs, obs, iens) - use mod_measurement - use m_insitu - use m_get_micom_dim - use m_get_micom_fld - !use m_parse_blkdat - use m_parameters - implicit none - - real, dimension(nobs), intent(inout) :: S - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - type(measurement), dimension(nobs) :: obs - integer, intent(in) :: iens - - real, parameter :: ONEMETER = 98060.0 - - ! obs stuff - ! - integer :: p, o - integer, allocatable, dimension(:) :: ipiv, jpiv - real, allocatable, dimension(:) :: a1, a2, a3, a4 - - ! grid stuff - ! - integer :: k - integer :: ni, nj, nk - real :: rdummy - - ! vertical stuff - ! - real, allocatable, dimension(:) :: zgrid, zcentre, zgrid_prev, zcentre_prev - real, allocatable, dimension(:) :: v, v_prev - - ! fields & I/O stuff - ! - real, allocatable, dimension(:, :) :: dz2d, v2d, sstbias, mld, offset, z - integer :: tlevel - character(8) :: fieldtag - character(3) :: cmem - character(80) :: fname - real, dimension(2, 2) :: dz_cell, v_cell - real :: dz, depth, z0, z1, z01, delta - integer :: field - - field = NONE - - if (nobs == 0) then - return - end if - - if (master .and. iens == 1) then - if (VERT_INTERP_GRID) then - print *, trim(obstag), ': vertical interpolation in grid space' - else - print *, trim(obstag), ': vertical interpolation in physical space' - end if - end if - - ! - ! 1. Identify profiles presented in "obs" - ! - - ! note that profiles are being used by each - ! ensemble member... - ! - call insitu_setprofiles(obstag, nobs, obs) - - allocate(ipiv(nprof)) - allocate(jpiv(nprof)) - allocate(a1(nprof)) - allocate(a2(nprof)) - allocate(a3(nprof)) - allocate(a4(nprof)) - allocate(zgrid(nprof)) - allocate(zgrid_prev(nprof)) - allocate(zcentre(nprof)) - allocate(zcentre_prev(nprof)) - allocate(v(nprof)) - allocate(v_prev(nprof)) - - ipiv = obs(pstart(1 : nprof)) % ipiv - jpiv = obs(pstart(1 : nprof)) % jpiv - a1 = obs(pstart(1 : nprof)) % a1 - a2 = obs(pstart(1 : nprof)) % a2 - a3 = obs(pstart(1 : nprof)) % a3 - a4 = obs(pstart(1 : nprof)) % a4 - - ! - ! 2. Map the observations for this ensemble member proceeding by layers - ! to reduce I/O: - ! - ! -cycle through layers - ! -find the middle of this layer - ! -cycle through profiles - ! -for each obs between the middle of the prev layer and the - ! middle of this layer - ! -interpolate the field value - ! -write to S - ! - - ! get grid dimensions - ! -! call parse_blkdat('idm ','integer', rdummy, ni) -! call parse_blkdat('jdm ','integer', rdummy, nj) -! call parse_blkdat('kdm ','integer', rdummy, nk) - call get_micom_dim(ni, nj, nk) - - allocate(v2d(ni, nj)) - allocate(dz2d(ni, nj)) - - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then - fieldtag = 'saln ' - field = SALINITY - elseif (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then - fieldtag = 'temp ' - field = TEMPERATURE - else - if (master) then - print *, 'ERROR: get_S(): unknown observatioon tag "', trim(obstag), '"' - end if - stop - end if - write(cmem, '(i3.3)') iens - fname = 'forecast'//cmem - - if (field == TEMPERATURE .and. prm_prmestexists('sstb')) then - allocate(sstbias(ni, nj)) - allocate(mld(ni, nj)) - allocate(offset(ni, nj)) - allocate(z(ni, nj)) - z = 0.0d0 - - tlevel = 1 - call get_micom_fld_new(trim(fname), sstbias, 'sstb ', 0, tlevel, ni, nj) - if (tlevel == -1) then - if (master) then - print *, 'ERROR: get_micom_fld_new(): failed for "sstb"' - end if - stop - end if - call get_micom_fld_new(trim(fname), mld, 'dpmixl ', 0, tlevel, ni, nj) - if (tlevel == -1) then - if (master) then - print *, 'ERROR: get_micom_fld_new(): failed for "dpmixl"' - end if - stop - end if - end if - - ! cycle through layers - ! - tlevel = 1 - do k = 1, nk + 1 - - if (k == 1) then - zgrid_prev = 0.0 - zcentre_prev = 0.0 - end if - - if (k <= nk) then - - ! read the depth and the requested field at this layer - ! - call get_micom_fld_new(trim(fname), dz2d, 'dp ', k, tlevel, ni, nj) - if (tlevel == -1) then - if (master) then - print *, 'ERROR: get_micom_fld_new(): failed for "dp"' - end if - stop - end if - call get_micom_fld_new(trim(fname), v2d, fieldtag, k, tlevel, ni, nj) - if (tlevel == -1) then - if (master) then - print *, 'ERROR: get_micom_fld_new(): failed for "', fieldtag, '"' - end if - stop - end if - end if - - ! calculate correction from SST bias at this depth - ! - if (field == TEMPERATURE .and. prm_prmestexists('sstb')) then - offset = 0.0d0 - z = z + dz2d / 2.0 ! at the middle of the layer - where (mld > 0.0d0 .and. mld < 1.0d8) ! < 10000 m - offset = sstbias * exp(-(z / mld) ** 2) - end where - v2d = v2d - offset - z = z + dz2d / 2.0 - end if - - ! cycle through profiles - ! - do p = 1, nprof - if (k <= nk) then - dz_cell(:, :) = dz2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1) - dz = dz_cell(1, 1) * a1(p) + dz_cell(2, 1) * a2(p)& - + dz_cell(1, 2) * a3(p) + dz_cell(2, 2) * a4(p) - dz = dz / ONEMETER - zgrid(p) = zgrid_prev(p) + dz - zcentre(p) = (zgrid_prev(p) + zgrid(p)) / 2.0 - v_cell(:, :) = v2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1) - v(p) = v_cell(1, 1) * a1(p) + v_cell(2, 1) * a2(p)& - + v_cell(1, 2) * a3(p) + v_cell(2, 2) * a4(p) - else - ! for the lower half of the last layer -- just use the layer value - ! (note that there was no reading in this case, so that - ! v = v_prev) - zcentre(p) = zgrid(p) - end if - - if (k == 1) then - v_prev(p) = v(p) - end if - - ! cycle through the obs, pick the ones in between the middle of the - ! previous layer and the middle of this layer, interpolate the - ! ensemble field to their locations, and save the results in S - ! - z0 = zcentre_prev(p) - z1 = zcentre(p) - z01 = zgrid_prev(p) - if (z1 == z0) then - cycle - end if - do while (pstart(p) <= pend(p)) - o = pstart(p) - depth = obs(o) % depth - - ! check that this obs is within the current layer - ! - if (depth > z1 .and. k <= nk) then - exit ! next profile - elseif (depth >= z0 .and. depth <= z1) then - - if (.not. VERT_INTERP_GRID) then - ! interpolate linearly in physical space - ! - S(o) = (z1 - depth) / (z1 - z0) * v_prev(p) +& - (depth - z0) / (z1 - z0) * v(p) - else - ! interpolate linearly in the grid space - ! - if (depth < z01) then - delta = 0.5d0 * (depth - z0) / (z01 - z0) - else - delta = 0.5d0 + 0.5d0 * (depth - z01) / (z1 - z01) - end if - S(o) = (1.0d0 - delta) * v_prev(p) + delta * v(p) - end if - - ! Here we check the range of interpolated ensemble values; - ! the range of observed values is checked in insitu_QC(). - ! - if (field == SALINITY) then - if ((S(o) < SAL_MIN .or. S(o) > SAL_MAX) .and. master) then - print *, 'WARNING: get_S(): suspicious value (SAL): ',& - 'iens =', iens, ', obs =', o, ', profile = ', p,& - 'depth =', depth, ', S =', S(o) - end if - else if (field == TEMPERATURE) then - if ((S(o) < TEM_MIN .or. S(o) > TEM_MAX) .and. master) then - print *, 'WARNING: get_S(): suspicious value (TEM): ',& - 'iens =', iens, ', obs =', o, ', profile = ', p,& - 'depth =', depth, ', S =', S(o) - print *, v_cell - print *, dz_cell - print *, delta, v_prev(p), v(p) - print *, dz - print *, a1(p), a2(p), a3(p), a4(p) - print *, ipiv(p), jpiv(p) - stop - end if - end if - else ! k == nk + 1 - S(o) = v(p) - end if - ! go to the next obs - ! - pstart(p) = pstart(p) + 1 - end do ! o - end do ! p - zgrid_prev = zgrid - zcentre_prev = zcentre - v_prev = v - end do ! k - - deallocate(dz2d) - deallocate(v2d) - deallocate(v_prev) - deallocate(v) - deallocate(zcentre_prev) - deallocate(zcentre) - deallocate(zgrid_prev) - deallocate(zgrid) - deallocate(a4) - deallocate(a3) - deallocate(a2) - deallocate(a1) - deallocate(jpiv) - deallocate(ipiv) - if (allocated(sstbias)) then - deallocate(sstbias) - deallocate(mld) - deallocate(offset) - deallocate(z) - end if - end subroutine get_S - - - ! Get S = HA for in-situ data. Piecewise cubic Hermite interpolate for - ! obs positioned between the first and last layer centres; otherwise use - ! the layer value for the obs above the middle of the first layer or - ! below the middle of the last layer. - ! - ! Note - this procedure parses through all obs for each ensemble member - ! to work out profiles. This indeed invlolves some redundancy because - ! this work could be done only once. However, the penalty (I think) is - ! quite small compared to the time required for reading the fields from - ! files and does not worth modifying (and complicating) the code. - ! - subroutine get_S_spline(S, obstag, nobs, obs, iens) - use mod_measurement - use mod_eosfun - use m_insitu - use m_get_micom_dim - use m_get_micom_fld - use m_parameters - - implicit none - - real, dimension(nobs), intent(inout) :: S - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - type(measurement), dimension(nobs) :: obs - integer, intent(in) :: iens - - real, parameter :: g = 980.6 ! cm/s^2 - - ! obs stuff - ! - integer :: p, o, o1, o2 - integer, allocatable, dimension(:) :: ipiv, jpiv - real, allocatable, dimension(:) :: a1, a2, a3, a4 - - ! grid stuff - ! - integer :: k, m, n - integer :: ni, nj, nk - - ! vertical stuff - ! - real, allocatable, dimension(:) :: zgrid, zcentre - real, allocatable, dimension(:) :: v, vd - - ! fields & I/O stuff - ! - real, allocatable, dimension(:, :, :) :: dz3d, v3d - real, allocatable, dimension(:, :, :) :: temp, saln - integer :: tlevel - character(8) :: fieldtag - character(3) :: cmem - character(80) :: fname - real, dimension(2, 2) :: dz_cell, v_cell, th_cell, sa_cell - real :: dz, th, sa, plo, dphi, alp1, alp2 - integer :: field - - field = NONE - - if (nobs == 0) then - return - end if - - if (master .and. iens == 1) then - print *, trim(obstag), ': spline vertical interpolation in grid space' - end if - - ! - ! Define coefficients for equation of state functions - ! - call eosini - - ! - ! 1. Identify profiles presented in "obs" - ! - - ! note that profiles are being used by each - ! ensemble member... - ! - call insitu_setprofiles(obstag, nobs, obs) - - allocate(ipiv(nprof)) - allocate(jpiv(nprof)) - allocate(a1(nprof)) - allocate(a2(nprof)) - allocate(a3(nprof)) - allocate(a4(nprof)) - - ipiv = obs(pstart(1 : nprof)) % ipiv - jpiv = obs(pstart(1 : nprof)) % jpiv - a1 = obs(pstart(1 : nprof)) % a1 - a2 = obs(pstart(1 : nprof)) % a2 - a3 = obs(pstart(1 : nprof)) % a3 - a4 = obs(pstart(1 : nprof)) % a4 - - ! - ! 2. Map the observations for this ensemble member proceeding by layers - ! to reduce I/O: - ! - - ! get grid dimensions - ! - call get_micom_dim(ni, nj, nk) - - allocate(v3d(ni, nj, nk)) - allocate(dz3d(ni, nj, nk)) - allocate(temp(ni, nj, nk)) - allocate(saln(ni, nj, nk)) - allocate(zgrid(nk)) - allocate(zcentre(nk)) - allocate(v(nk)) - allocate(vd(nk)) - - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then - fieldtag = 'saln ' - field = SALINITY - elseif (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then - fieldtag = 'temp ' - field = TEMPERATURE - else - if (master) then - print *, 'ERROR: get_S_spline(): unknown observatioon tag "', trim(obstag), '"' - end if - stop - end if - write(cmem, '(i3.3)') iens - fname = 'forecast'//cmem - - tlevel = 1 - ! read the depth and the requested field at all layers - ! - call get_micom_fld(trim(fname), dz3d, 'dp ', tlevel, ni, nj, nk) - call get_micom_fld(trim(fname), temp, 'temp', tlevel, ni, nj, nk) - call get_micom_fld(trim(fname), saln, 'saln', tlevel, ni, nj, nk) - - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then - v3d = saln - elseif (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then - v3d = temp - else - if (master) then - print *, 'ERROR: get_S_spline(): unknown observatioon tag "', trim(obstag), '"' - end if - stop - end if - !call get_micom_fld(trim(fname), v3d, fieldtag, tlevel, ni, nj, nk) - - ! cycle through profiles - ! - do p = 1, nprof - ! cycle through layers - ! - do k = 1, nk - if (k == 1) then - m = 1 - zgrid = 0. - zcentre = 0. - plo = 0. - end if - dz_cell(:, :) = dz3d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1, k) - dz = dz_cell(1, 1) * a1(p) + dz_cell(2, 1) * a2(p)& - + dz_cell(1, 2) * a3(p) + dz_cell(2, 2) * a4(p) - - if (dz .lt. 1.) cycle ! strictly insrease - - th_cell = temp(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1, k) - th = th_cell(1, 1) * a1(p) + th_cell(2, 1) * a2(p)& - + th_cell(1, 2) * a3(p) + th_cell(2, 2) * a4(p) - - sa_cell = saln(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1, k) - sa = sa_cell(1, 1) * a1(p) + sa_cell(2, 1) * a2(p)& - + sa_cell(1, 2) * a3(p) + sa_cell(2, 2) * a4(p) - - plo = plo + dz - call delphi(plo, plo - dz, th, sa, dphi, alp1, alp2) - dz = dphi / g / 100 ! cm -> meter - - if (m == 1) then - zcentre(m) = dz / 2.0 - zgrid(m) = zcentre(m) + dz / 2.0 - else - zcentre(m) = zgrid(m-1) + dz / 2.0 - zgrid(m) = zcentre(m) + dz / 2.0 - end if - v_cell(:, :) = v3d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1, k) - v(m) = v_cell(1, 1) * a1(p) + v_cell(2, 1) * a2(p)& - + v_cell(1, 2) * a3(p) + v_cell(2, 2) * a4(p) - m = m + 1 - end do ! k - m = m - 1 - - ! observation length in the profile - n = pend(p) - pstart(p) + 1 - - ! first obs below the first model layer centre - o1 = pstart(p) - do while (o1 .le. pend(p) .and. obs(o1) % depth .lt. zcentre(1)) - o1 = o1 + 1 - end do - - ! last obs above the last model layer centre - o2 = pend(p) - do while (o2 .ge. pstart(p) .and. obs(o2) % depth .gt. zcentre(m)) - o2 = o2 - 1 - end do - - if (o1 .gt. o2+1) then - if (master) then - print *, 'ERROR: get_S_spline(): failed for first and last obs in the range' - print *, 'pstart =', pstart(p) - print *, 'pend =', pend(p) - print *, 'o1 =', o1 - print *, 'o2 =', o2 - print *, 'zcentre =', zcentre - print *, 'm =', m - print *, 'obs % depth =', obs(pstart(p):pend(p)) % depth - print *, a1(p), a2(p), a3(p), a4(p) - print *, ipiv(p), jpiv(p) - end if - stop - end if - - ! use the first value for the obs above the middle of the first layer - do o = pstart(p), o1-1 - S(o) = v(1) - end do - - ! use the last value for the obs below the middle of the last layer - do o = o2+1, pend(p) - S(o) = v(m) - end do - - if (o2 - o1 .ge. 0) then - call spline_pchip_set(m, zcentre(1:m), v(1:m), vd(1:m)) - call spline_pchip_val(m, zcentre(1:m), v(1:m), vd(1:m), o2 - o1 + 1, & - obs(o1:o2) % depth, S(o1:o2)) - end if - - ! Here we check the range of interpolated ensemble values; - ! the range of observed values is checked in insitu_QC(). - ! - do o = pstart(p), pend(p) - if (field == SALINITY) then - if ((S(o) < SAL_MIN .or. S(o) > SAL_MAX)) then -!!$ print *, 'WARNING: get_S(): suspicious value (SAL): ',& -!!$ 'iens =', iens, ', obs =', o, ', profile = ', p,& -!!$ 'depth =', obs(o) % depth, ', S =', S(o) -!!$ print *, zcentre(1:m) -!!$ print *, v(1:m) -!!$ print *, a1(p), a2(p), a3(p), a4(p) -!!$ print *, ipiv(p), jpiv(p) - if (S(o) < SAL_MIN) then - S(o) = SAL_MIN - else - S(o) = SAL_MAX - end if - end if - else if (field == TEMPERATURE) then - if ((S(o) < TEM_MIN .or. S(o) > TEM_MAX)) then -!!$ print *, 'WARNING: get_S(): suspicious value (TEM): ',& -!!$ 'iens =', iens, ', obs =', o, ', profile = ', p,& -!!$ 'depth =', obs(o) % depth, ', S =', S(o) -!!$ print *, zcentre(1:m) -!!$ print *, v(1:m) -!!$ print *, a1(p), a2(p), a3(p), a4(p) -!!$ print *, ipiv(p), jpiv(p) - if (S(o) < TEM_MIN) then - S(o) = TEM_MIN - else - S(o) = TEM_MAX - end if - end if - end if - end do ! o - end do ! p - - deallocate(dz3d, v3d, v, vd) - deallocate(zcentre, zgrid) - deallocate(a1, a2, a3, a4) - deallocate(ipiv, jpiv) - end subroutine get_S_spline - - ! Get climatological data. Piecewise cubic Hermite interpolate for - ! obs positioned between min and max avlaible depths; otherwise use - ! the first value for the obs above the first model depth or - ! the last value below the last model depth. - ! - subroutine get_climato_spline(S, obstag, nobs, obs) - use mod_measurement - use m_insitu - use m_get_micom_dim - use m_get_micom_fld - use m_parameters - use ieee_arithmetic - implicit none - - real, dimension(nobs), intent(inout) :: S - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - type(measurement), dimension(nobs) :: obs - - ! obs stuff - ! - integer :: p, o, o1, o2 - integer, allocatable, dimension(:) :: ipiv, jpiv - real, allocatable, dimension(:) :: a1, a2, a3, a4 - - ! grid stuff - ! - integer :: k, m, n - integer :: ni, nj, nk - - ! vertical stuff - ! - real, allocatable, dimension(:) :: zgrid, zcentre - real, allocatable, dimension(:) :: v, vd - - ! fields & I/O stuff - ! - real, allocatable, dimension(:) :: dz3d - real, allocatable, dimension(:, :, :) :: v3d - integer :: tlevel - character(8) :: fieldtag - - character(80) :: fname - real, dimension(2, 2) :: dz_cell, v_cell - real :: dz - integer :: field - - field = NONE - - if (nobs == 0) then - return - end if - - if (master) then - print *, trim(obstag), ': climatology spline vertical interpolation in grid space' - end if - - ! - ! 1. Identify profiles presented in "obs" - ! - call insitu_setprofiles(obstag, nobs, obs) - - allocate(ipiv(nprof), jpiv(nprof)) - allocate(a1(nprof), a2(nprof), a3(nprof), a4(nprof)) - - ipiv = obs(pstart(1 : nprof)) % ipiv - jpiv = obs(pstart(1 : nprof)) % jpiv - a1 = obs(pstart(1 : nprof)) % a1 - a2 = obs(pstart(1 : nprof)) % a2 - a3 = obs(pstart(1 : nprof)) % a3 - a4 = obs(pstart(1 : nprof)) % a4 - - ! - ! 2. Map the observations for climatology proceeding by depth - ! - - ! get grid dimensions - ! - call get_climato_dim(ni, nj, nk) - - allocate(v3d(ni, nj, nk)) - allocate(dz3d(nk)) - allocate(zgrid(nk)) - allocate(zcentre(nk)) - allocate(v(nk)) - allocate(vd(nk)) - - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then - fieldtag = 'saln ' - field = SALINITY - elseif (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then - fieldtag = 'temp ' - field = TEMPERATURE - else - if (master) then - print *, 'ERROR: get_S(): unknown observatioon tag "', trim(obstag), '"' - end if - stop - end if - - fname = 'mean_mod' - tlevel = 1 - ! read the depth and the requested field at all layers - ! - call get_micom_fld_1d(trim(fname), dz3d, 'depth', nk) - call get_micom_fld(trim(fname), v3d, trim(fieldtag)//'lvl', tlevel, ni, nj, nk) - - ! cycle through profiles - do p = 1, nprof - ! cycle through layers - m = 1 - do k = 1, nk - dz = dz3d(k) - zcentre(m) = dz - - v_cell(:, :) = v3d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1, k) - v(m) = v_cell(1, 1) * a1(p) + v_cell(2, 1) * a2(p)& - + v_cell(1, 2) * a3(p) + v_cell(2, 2) * a4(p) - if (count(v_cell < -32766.) .gt. 0) cycle - m = m + 1 - end do ! k - m = m - 1 - - ! observation length in the profile - n = pend(p) - pstart(p) + 1 - - ! first obs below the first model depth - o1 = pstart(p) - do while (o1 .le. pend(p) .and. obs(o1) % depth .lt. zcentre(1)) - o1 = o1 + 1 - end do - - ! first obs above the last model depth - o2 = pend(p) - do while (o2 .ge. pstart(p) .and. obs(o2) % depth .gt. zcentre(m)) - o2 = o2 - 1 - end do - - if (o1 .gt. o2+1) then - if (master) then - print *, 'ERROR: get_climato_spline(): failed for first and last obs in the range' - print *, 'pstart =', pstart(p) - print *, 'pend =', pend(p) - print *, 'o1 =', o1 - print *, 'o2 =', o2 - print *, 'zcentre =', zcentre - print *, 'value = ', v - print *, 'm =', m - print *, 'obs % depth =', obs(pstart(p):pend(p)) % depth - print *, a1(p), a2(p), a3(p), a4(p) - print *, ipiv(p), jpiv(p) - end if - stop - end if - - ! use the first value for the obs above the first depth - do o = pstart(p), o1-1 - S(o) = v(1) - end do - - ! use the last value for the obs below the last depth - do o = o2+1, pend(p) - S(o) = v(m) - end do - - if (o2 - o1 .ge. 0) then - call spline_pchip_set(m, zcentre(1:m), v(1:m), vd(1:m)) - call spline_pchip_val(m, zcentre(1:m), v(1:m), vd(1:m), o2 - o1 + 1, & - obs(o1:o2) % depth, S(o1:o2)) - end if - - ! Here we check the range of interpolated values; - ! the range of observed values is checked in insitu_QC(). - ! - do o = pstart(p), pend(p) - if (ieee_is_nan(S(o))) then - print *, 'WARNING: get_Climato_S(): find nan: ',& - 'obs =', o, ', profile = ', p,& - 'depth =', obs(o) % depth, ', S =', S(o) - print *, zcentre(1:m) - print *, v(1:m) - print *, a1(p), a2(p), a3(p), a4(p) - print *, ipiv(p), jpiv(p) - end if - if (field == SALINITY) then - if ((S(o) < SAL_MIN .or. S(o) > SAL_MAX)) then - if (S(o) < SAL_MIN) then - S(o) = SAL_MIN - else - S(o) = SAL_MAX - end if - end if - else if (field == TEMPERATURE) then - if ((S(o) < TEM_MIN .or. S(o) > TEM_MAX)) then - if (S(o) < TEM_MIN) then - S(o) = TEM_MIN - else - S(o) = TEM_MAX - end if - end if - end if - end do ! o - end do ! p - - if (master) then - print *, trim(obstag), ': End of climatology splining vertical interpolation in grid space' - end if - - deallocate(dz3d, v3d, v, vd) - deallocate(zcentre, zgrid) - deallocate(a1, a2, a3, a4) - deallocate(ipiv, jpiv) - end subroutine get_climato_spline - -end module m_Generate_element_Si diff --git a/assim/enkf_cf-system2_old/EnKF/m_bilincoeff.F90 b/assim/enkf_cf-system2_old/EnKF/m_bilincoeff.F90 deleted file mode 100755 index 62b5b49e..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_bilincoeff.F90 +++ /dev/null @@ -1,119 +0,0 @@ -module m_bilincoeff - use m_oldtonew - implicit none - -contains - - ! This subroutine uses bilinear interpolation to interpolate the field - ! computed by the model (MICOM) to the position defined by lon, lat - ! The output is the interpolation coeffisients a[1-4] - ! NB NO locations on land. - ! - subroutine bilincoeff(glon, glat, nx, ny, lon, lat, ipiv, jpiv, a1, a2, a3, a4) - real, intent(in) :: glon(nx, ny), glat(nx, ny) - integer, intent(in) :: nx ,ny - real, intent(in) :: lon, lat - integer, intent(in) :: ipiv, jpiv - real, intent(out) :: a1, a2, a3, a4 - - real :: t, u - real :: lat1, lon1, lat2, lon2, latn, lonn - - - call oldtonew(glat(ipiv, jpiv), glon(ipiv, jpiv), lat1, lon1) - call oldtonew(glat(ipiv + 1, jpiv + 1), glon(ipiv + 1, jpiv + 1), lat2, lon2) - call oldtonew(lat, lon, latn, lonn) - - t = (lonn - lon1) / (lon2 - lon1) - u = (latn - lat1) / (lat2 - lat1) - - if (t < -0.1 .or. t > 1.1 .or. u < -0.1 .or. u > 1.1) then - print *, 'ERROR: bilincoeff(): t, u = ', t, u, 'for lon, lat =', lon, lat - stop - end if - - a1 = (1.0 - t) * (1.0 - u) - a2 = t * (1.0 - u) - a3 = t * u - a4 = (1.0 - t) * u - end subroutine bilincoeff - - subroutine bilincoeff1(glon, glat, nx, ny, lon, lat, ipiv, jpiv, a1, a2, a3, a4) - use ieee_arithmetic - real, intent(in) :: glon(nx, ny), glat(nx, ny) - integer, intent(in) :: nx ,ny - real, intent(in) :: lon, lat - integer, intent(in) :: ipiv, jpiv - real, intent(out) :: a1, a2, a3, a4 - - real :: xx(4), yy(4) - real :: t, u - real :: EPS=1.0e-8 - - xx(1) = glon(ipiv, jpiv) - xx(2) = glon(ipiv + 1, jpiv) - xx(3) = glon(ipiv + 1, jpiv + 1) - xx(4) = glon(ipiv, jpiv + 1) - yy(1) = glat(ipiv, jpiv) - yy(2) = glat(ipiv + 1, jpiv) - yy(3) = glat(ipiv + 1, jpiv + 1) - yy(4) = glat(ipiv, jpiv + 1) - call xy2fij(lon, lat, xx, yy, t, u) - - if (t < -EPS .or. t > 1 + EPS .or. u < -EPS .or. u > 1 + EPS) then - !print *, 'ERROR: bilincoeff1()', t, u - t=0. - u=0. - end if - - ! check nan - if (ieee_is_nan(t) .or. ieee_is_nan(u)) then - t = 0. - u = 0. - end if - - a1 = (1.0 - t) * (1.0 - u) - a2 = t * (1.0 - u) - a3 = t * u - a4 = (1.0 - t) * u - - end subroutine bilincoeff1 - - subroutine xy2fij(x, y, xx, yy, fi, fj) - real, intent(in) :: x, y - real, intent(in) :: xx(4), yy(4) - real, intent(out) :: fi, fj - - real :: a, b, c, d, e, f, g, h - real :: aa, bb, cc - real :: d1, d2 - - a = xx(1) - xx(2) - xx(4) + xx(3) - b = xx(2) - xx(1) - c = xx(4) - xx(1) - d = xx(1) - e = yy(1) - yy(2) - yy(4) + yy(3) - f = yy(2) - yy(1) - g = yy(4) - yy(1) - h = yy(1) - - aa = a * f - b * e; - bb = e * x - a * y + a * h - d * e + c * f - b * g; - cc = g * x - c * y + c * h - d * g; - - if (abs(aa) < 1d-5) then - fi = -cc / bb * (1.0d0 + aa * cc / bb / bb); - else - fi = (-bb - sqrt(bb * bb - 4.0d0 * aa * cc)) / (2.0d0 * aa); - end if - - d1 = a * fi + c - d2 = e * fi + g - if (abs(d2) > abs(d1)) then - fj = (y - f * fi - h) / d2 - else - fj = (x - b * fi - d) / d1 - end if - end subroutine xy2fij - -end module m_bilincoeff diff --git a/assim/enkf_cf-system2_old/EnKF/m_confmap.F90 b/assim/enkf_cf-system2_old/EnKF/m_confmap.F90 deleted file mode 100755 index dbdf3e5d..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_confmap.F90 +++ /dev/null @@ -1,121 +0,0 @@ -module m_confmap - implicit none - - logical :: confmap_initialised = .false. - - real :: pi_1 - real :: pi_2 - real :: deg - real :: rad - real :: theta_a - real :: phi_a - real :: theta_b - real :: phi_b - real :: di - real :: dj - complex :: imagone - complex :: ac - complex :: bc - complex :: cmna - complex :: cmnb - real :: mu_s - real :: psi_s - real :: epsil - logical :: mercator - - real :: lat_a, lon_a - real :: lat_b, lon_b - real :: wlim, elim - real :: slim, nlim - real :: mercfac - integer :: ires, jres - -contains - - ! This routine initializes constants used in the conformal mapping - ! and must be called before the routines 'oldtonew' and 'newtoold' - ! are called. The arguments of this routine are the locations of - ! the two poles in the old coordiante system. - ! - subroutine confmap_init(nx, ny) - integer, intent(in) :: nx, ny - - real :: cx, cy, cz, theta_c, phi_c - complex :: c, w - logical :: ass, lold - - ! Read info file - open(unit = 10, file = 'grid.info', form = 'formatted') - read(10, *) lat_a, lon_a - read(10, *) lat_b,lon_b - read(10, *) wlim, elim, ires - read(10, *) slim, nlim, jres - read(10, *) ass - read(10, *) ass - read(10, *) ass - read(10, *) mercator - read(10, *) mercfac, lold - close(10) - if (ires /= nx .and. jres /= ny) then - print *, 'initconfmap: WARNING -- the dimensions in grid.info are not' - print *, 'initconfmap: WARNING -- consistent with nx and ny' - print *, 'initconfmap: WARNING -- IGNORE IF RUNNING CURVIINT' - stop '(initconfmap)' - endif - - ! some constants - ! - pi_1 = 3.14159265358979323846 - pi_2 = 0.5 * pi_1 - deg = 180.0 / pi_1 - rad = 1.0 / deg - epsil = 1.0d-9 - - di = (elim - wlim) / real(ires - 1) ! delta lon' - dj = (nlim - slim) / real(jres - 1) ! delta lat' for spherical grid - - if (mercator) then - dj = di - if (lold) then - print *, 'initconfmap: lold' - slim = -mercfac * jres * dj - else - print *, 'initconfmap: not lold' - slim = mercfac - endif - endif - - ! transform to spherical coordinates - ! - theta_a = lon_a * rad - phi_a = pi_2 - lat_a * rad - theta_b = lon_b * rad - phi_b = pi_2 - lat_b * rad - - ! find the angles of a vector pointing at a point located exactly - ! between the poles - ! - cx = cos(theta_a) * sin(phi_a) + cos(theta_b) * sin(phi_b) - cy = sin(theta_a) * sin(phi_a) + sin(theta_b) * sin(phi_b) - cz = cos(phi_a) + cos(phi_b) - - theta_c = atan2(cy, cx) - phi_c = pi_2 - atan2(cz, sqrt(cx * cx + cy * cy)) - - ! initialize constants used in the conformal mapping - ! - imagone = (0.0, 1.0) - ac = tan(0.5 * phi_a) * exp(imagone * theta_a) - bc = tan(0.5 * phi_b) * exp(imagone * theta_b) - c = tan(0.5 * phi_c) * exp(imagone * theta_c) - cmna = c - ac - cmnb = c - bc - - w = cmnb / cmna - mu_s = atan2(aimag(w), real(w)) - psi_s = 2.0 * atan(abs(w)) - - confmap_initialised = .true. - end subroutine confmap_init - -end module m_confmap diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_cice_dim.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_cice_dim.F90 deleted file mode 100755 index 9628cceb..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_cice_dim.F90 +++ /dev/null @@ -1,29 +0,0 @@ -module m_get_cice_dim -contains -subroutine get_cice_dim(ncat,ikdm,skdm) - use netcdf - use nfw_mod - - implicit none - integer, intent(out) :: ncat,ikdm,skdm - integer :: ncid, ncat_ID, ikdm_ID, skdm_ID - - logical ex - - inquire(file='forecast_ice001.nc',exist=ex) - if (ex) then - ! Reading the grid file - call nfw_open('forecast_ice001.nc', nf_nowrite, ncid) - ! Get dimension id in netcdf file ... - call nfw_inq_dimid('forecast_ice001.nc', ncid, 'ncat', ncat_ID) - call nfw_inq_dimid('forecast_ice001.nc', ncid, 'ntilyr', ikdm_ID) - call nfw_inq_dimid('forecast_ice001.nc', ncid, 'ntslyr', skdm_ID) - !Get the dimension - call nfw_inq_dimlen('forecast_ice001.nc', ncid, ncat_ID, ncat) - call nfw_inq_dimlen('forecast_ice001.nc', ncid, ikdm_ID, ikdm) - call nfw_inq_dimlen('forecast_ice001.nc', ncid, skdm_ID, skdm) - else - stop 'ERROR: file forecast_ice001.nc is missing' - endif -end subroutine get_cice_dim -end module m_get_cice_dim diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_micom_dim.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_micom_dim.F90 deleted file mode 100755 index 90533d1b..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_micom_dim.F90 +++ /dev/null @@ -1,58 +0,0 @@ -module m_get_micom_dim -contains -subroutine get_micom_dim(nx,ny,nz) - use netcdf - use nfw_mod - - implicit none - integer, intent(out) :: nx,ny,nz - integer ncid, x_ID, y_ID, z_ID - - logical ex - - inquire(file='forecast001.nc',exist=ex) - - if (ex) then - ! Reading the grid file - call nfw_open('forecast001.nc', nf_nowrite, ncid) - ! Get dimension id in netcdf file ... - call nfw_inq_dimid('forecast001.nc', ncid, 'x', x_ID) - call nfw_inq_dimid('forecast001.nc', ncid, 'y', y_ID) - call nfw_inq_dimid('forecast001.nc', ncid, 'kk', z_ID) - !Get the dimension - call nfw_inq_dimlen('forecast001.nc', ncid, x_ID, nx) - call nfw_inq_dimlen('forecast001.nc', ncid, y_ID, ny) - call nfw_inq_dimlen('forecast001.nc', ncid, z_ID, nz) - else - stop 'ERROR: file forecast001.nc is missing' - endif -end subroutine get_micom_dim - -subroutine get_climato_dim(nx,ny,nz) - use netcdf - use nfw_mod - - implicit none - integer, intent(out) :: nx,ny,nz - integer ncid, x_ID, y_ID, z_ID - - logical ex - - inquire(file='mean_mod.nc',exist=ex) - - if (ex) then - ! Reading the grid file - call nfw_open('mean_mod.nc', nf_nowrite, ncid) - ! Get dimension id in netcdf file ... - call nfw_inq_dimid('mean_mod.nc', ncid, 'x', x_ID) - call nfw_inq_dimid('mean_mod.nc', ncid, 'y', y_ID) - call nfw_inq_dimid('mean_mod.nc', ncid, 'depth', z_ID) - !Get the dimension - call nfw_inq_dimlen('mean_mod.nc', ncid, x_ID, nx) - call nfw_inq_dimlen('mean_mod.nc', ncid, y_ID, ny) - call nfw_inq_dimlen('mean_mod.nc', ncid, z_ID, nz) - else - stop 'ERROR: file mean_mod.nc is missing' - endif - end subroutine get_climato_dim -end module m_get_micom_dim diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_micom_fld.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_micom_fld.F90 deleted file mode 100755 index 34007c49..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_micom_fld.F90 +++ /dev/null @@ -1,197 +0,0 @@ -module m_get_micom_fld -use netcdf -use nfw_mod -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! KAL -- This routine reads one of the fields from the model, specified -! KAL -- by name, vertical level and time level -! KAL -- This routine is really only effective for the new restart files. -subroutine get_micom_fld_new(memfile,fld,cfld,vlevel,tlevel,nx,ny) -#if defined (QMPI) - use qmpi, only : qmpi_proc_num -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nx,ny ! Grid dimension - real, dimension(nx,ny), intent(out) :: fld ! output fld - character(len=*), intent(in) :: memfile! base name of input files - character(len=*), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - integer, intent(in) :: vlevel ! vertical level - - real, dimension(nx,ny) :: readfld - integer :: ex, ncid, vFIELD_ID - integer, allocatable :: ns(:), nc(:) - inquire(file=trim(memfile)//'.nc',exist=ex) - if (ex) then - ! Reading the observation file of satellite - call nfw_open(trim(memfile)//'.nc', nf_nowrite, ncid) - call nfw_inq_varid(trim(memfile)//'.nc', ncid,trim(cfld),vFIELD_ID) - if (vlevel==0) then - allocate(ns(3)) - allocate(nc(3)) - ns(1)=1 - ns(2)=1 - ns(3)=1 - nc(1)=nx - nc(2)=ny - nc(3)=1 - call nfw_get_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, readfld) - fld=readfld(:,:) - else - allocate(ns(4)) - allocate(nc(4)) - ns(1)=1 - ns(2)=1 - ns(3)=vlevel - ns(4)=1 - nc(1)=nx - nc(2)=ny - nc(3)=1 - nc(4)=1 - call nfw_get_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, readfld) - fld=readfld(:,:) - endif - call nfw_close(trim(memfile)//'.nc', ncid) - else - print *, 'ERROR: forecast file is missing '//trim(memfile)//'.nc' - stop - endif -end subroutine - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! KAL -- This routine reads one of the fields from the model, specified -! KAL -- by name and time level -! KAL -- This routine is really only effective for vertical interpolation -subroutine get_micom_fld(memfile,fld,cfld,tlevel,nx,ny,nz) -#if defined (QMPI) - use qmpi, only : qmpi_proc_num -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nx,ny,nz ! Grid dimension - real, dimension(nx,ny,nz), intent(out) :: fld ! output fld - character(len=*), intent(in) :: memfile ! base name of input files - character(len=*), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - - real, dimension(nx,ny,nz) :: readfld - integer :: ex, ncid, vFIELD_ID - integer, allocatable :: ns(:), nc(:) - inquire(file=trim(memfile)//'.nc',exist=ex) - if (ex) then - ! Reading the observation file of satellite - call nfw_open(trim(memfile)//'.nc', nf_nowrite, ncid) - call nfw_inq_varid(trim(memfile)//'.nc', ncid,trim(cfld),vFIELD_ID) - - allocate(ns(4)) - allocate(nc(4)) - ns(1)=1 - ns(2)=1 - ns(3)=1 - ns(4)=1 - nc(1)=nx - nc(2)=ny - nc(3)=nz - nc(4)=1 - call nfw_get_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, readfld) - fld=readfld(:,:,:) - call nfw_close(trim(memfile)//'.nc', ncid) - else - print *, 'ERROR: forecast file is missing '//trim(memfile)//'.nc' - stop - endif -end subroutine get_micom_fld - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! KAL -- This routine reads one dimension of the fields from the model outputs, specified -! KAL -- by name and vertical level -! KAL -- This routine is really only effective for vertical interpolation -subroutine get_micom_fld_1d(memfile,fld,cfld,nz) -#if defined (QMPI) - use qmpi, only : qmpi_proc_num -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nz ! Grid dimension - real, dimension(nz), intent(out) :: fld ! output fld - character(len=*), intent(in) :: memfile ! base name of input files - character(len=*), intent(in) :: cfld ! name of fld - - real, dimension(nz) :: readfld - integer :: ex, ncid, vFIELD_ID - - inquire(file=trim(memfile)//'.nc',exist=ex) - if (ex) then - ! Reading data - call nfw_open(trim(memfile)//'.nc', nf_nowrite, ncid) - call nfw_inq_varid(trim(memfile)//'.nc', ncid,trim(cfld),vFIELD_ID) - - call nfw_get_var_double(trim(memfile)//'.nc', ncid, vFIELD_ID, readfld) - fld = readfld - call nfw_close(trim(memfile)//'.nc', ncid) - else - print *, 'ERROR: file is missing '//trim(memfile)//'.nc' - stop - endif -end subroutine get_micom_fld_1d -subroutine get_micom_fld_ice(memfile,fld,cfld,vlevel,tlevel,nx,ny) -#if defined (QMPI) - use qmpi, only : master, stop_mpi, qmpi_proc_num -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nx,ny ! Grid dimension - real, dimension(nx,ny), intent(out) :: fld ! output fld - character(len=*), intent(in) :: memfile! base name of input files - character(len=*), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - integer, intent(in) :: vlevel ! vertical level -#if defined(TRIPOLAR) - real, dimension(nx,ny-1) :: readfld !MK: one dim size less for ice var. on triploar grid -#else - real, dimension(nx,ny) :: readfld -#endif -! real, dimension(nx,ny) :: readfld - integer :: ex, ncid, vFIELD_ID - integer, allocatable :: ns(:), nc(:) - inquire(file=trim(memfile)//'.nc',exist=ex) - if (ex) then - ! Reading the observation file of satellite - call nfw_open(trim(memfile)//'.nc', nf_nowrite, ncid) - call nfw_inq_varid(trim(memfile)//'.nc', ncid,trim(cfld),vFIELD_ID) - allocate(ns(3)) - allocate(nc(3)) - ns(1)=1 - ns(2)=1 - ns(3)=vlevel - nc(1)=nx -#if defined(TRIPOLAR) - nc(2)=ny-1 -#else - nc(2)=ny -#endif - nc(3)=1 - call nfw_get_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, readfld) -#if defined(TRIPOLAR) - fld(:,1:ny-1)= readfld(:,:) - fld(:,ny) = 0.0d0 -#else - fld(:,1:ny)= readfld(:,:) -#endif -! fld= readfld(:,:) - call nfw_close(trim(memfile)//'.nc', ncid) - else - print *, 'ERROR: forecast file is missing '//trim(memfile)//'.nc' - stop - endif -end subroutine - - -end module m_get_micom_fld - - diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_micom_grid.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_micom_grid.F90 deleted file mode 100755 index 7791cd42..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_micom_grid.F90 +++ /dev/null @@ -1,39 +0,0 @@ -module m_get_micom_grid -contains -subroutine get_micom_grid(modlon, modlat, depths, mindx, meandx, nx, ny) - use netcdf - use nfw_mod - - implicit none - integer, intent(in) :: nx,ny - real, dimension(nx,ny), intent(out) :: modlon,modlat,depths - real,intent(out) :: mindx,meandx - integer :: ncid, x_ID, y_ID, vLON_ID, vLAT_ID, vDEPTH_ID, vPDX_ID, vPDY_ID - real, dimension(nx,ny):: pdx,pdy - - logical ex - - inquire(file='grid.nc',exist=ex) - if (ex) then - ! Reading the grid file - call nfw_open('grid.nc', nf_nowrite, ncid) - ! Get dimension id in netcdf file ... - call nfw_inq_varid('grid.nc', ncid,'plon' ,vLON_ID) - call nfw_inq_varid('grid.nc', ncid,'plat' ,vLAT_ID) - call nfw_inq_varid('grid.nc', ncid,'pdepth' ,vDEPTH_ID) - call nfw_inq_varid('grid.nc', ncid,'pdx' ,vPDX_ID) - call nfw_inq_varid('grid.nc', ncid,'pdy' ,vPDY_ID) - call nfw_get_var_double('grid.nc', ncid, vLON_ID, modlon) - call nfw_get_var_double('grid.nc', ncid, vLAT_ID, modlat) - call nfw_get_var_double('grid.nc', ncid, vDEPTH_ID, depths) - call nfw_get_var_double('grid.nc', ncid, vPDX_ID, pdx) - call nfw_get_var_double('grid.nc', ncid, vPDY_ID, pdy) - call nfw_close('grid.nc', ncid) - mindx = min(real(minval(pdx,mask=depths>1.)), real(minval(pdy,mask=depths>1.))) - meandx=sum (pdx,mask=depths>1. .and. depths < 1e25) / & - count(depths>1. .and. depths < 1e25) - else - stop 'ERROR: file grid.nc is missing' - endif -end subroutine get_micom_grid -end module m_get_micom_grid diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_micom_nrens.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_micom_nrens.F90 deleted file mode 100755 index 279a34f9..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_micom_nrens.F90 +++ /dev/null @@ -1,61 +0,0 @@ -module m_get_micom_nrens - -contains - - integer function get_micom_nrens(nx, ny) -#if defined (QMPI) - use qmpi , only : stop_mpi, master -#else - use qmpi_fake -#endif - implicit none - - integer, intent(in) :: nx, ny - - integer imem - logical ex - character(len=3) :: cmem - - imem = 1 - ex = .true. - do while (ex) - write(cmem, '(i3.3)') imem - inquire(exist = ex, file = 'forecast' // cmem // '.nc') - if (ex) then - imem = imem + 1 - end if - end do - get_micom_nrens = imem - 1 - end function get_micom_nrens - !============================================ - ! GET_CICE_NRENS - !============================================ - integer function get_cice_nrens(nx, ny) -#if defined (QMPI) - use qmpi , only : stop_mpi, master -#else - use qmpi_fake -#endif - implicit none - - integer, intent(in) :: nx, ny - - integer imem - logical ex - character(len=3) :: cmem - - imem = 1 - ex = .true. - do while (ex) - write(cmem, '(i3.3)') imem - inquire(exist = ex, file = 'forecast_ice' // cmem // '.nc') - if (ex) then - imem = imem + 1 - end if - end do - get_cice_nrens = imem - 1 - end function get_cice_nrens - - - -end module m_get_micom_nrens diff --git a/assim/enkf_cf-system2_old/EnKF/m_get_mod_fld.F90 b/assim/enkf_cf-system2_old/EnKF/m_get_mod_fld.F90 deleted file mode 100755 index 7b166bbb..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_get_mod_fld.F90 +++ /dev/null @@ -1,147 +0,0 @@ -module m_get_mod_fld -! KAL -- This routine reads one of the fields from the model, specified -! KAL -- by name, vertical level and time level -! KAL -- This routine is really only effective for the new restart files. - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -subroutine get_mod_fld(fld,j,cfld,vlevel,tlevel,nx,ny) -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nx,ny ! Grid dimension - integer, intent(in) :: j ! Ensemble member to read - real, dimension(nx,ny), intent(out) :: fld ! output fld - character(len=*), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - integer, intent(in) :: vlevel ! vertical level - - integer reclICE - real*8, dimension(nx,ny) :: ficem,hicem,hsnwm,ticem,tsrfm - - logical ex - - character(len=*),parameter :: icefile='forecastICE.uf' - - ! KAL -- shortcut -- the analysis is for observation icec -- this little "if" - ! means the analysis will only work for ice. Add a check though - if ((trim(cfld)/='icec' .and. trim(cfld)/='hice') .or. vlevel/=0 .or. tlevel/=1)then - if (master) print *,'get_mod_fld only works for icec for now' - call stop_mpi() - end if - -!################################################################### -!####################### READ ICE MODEL ######################### -!################################################################### -#if defined (ICE) -#warning "COMPILING WITH ICE" - inquire(exist=ex,file=icefile) - if (.not.ex) then - if (master) then - print *,icefile//' does not exist!' - print *,'(get_mod_fld)' - end if - call stop_mpi() - end if - inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV - open(10,file=icefile,form='unformatted',access='direct',recl=reclICE) - read(10,rec=j)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV - if (trim(cfld)=='icec') fld = ficem - if (trim(cfld)=='hice') fld = hicem - close(10) -#else -#warning "COMPILING WITHOUT ICE" -#endif - - - return -end subroutine get_mod_fld - - - -! KAL - This is for the new file type -subroutine get_mod_fld_new(memfile,fld,iens,cfld,vlevel,tlevel,nx,ny) - use mod_raw_io -#if defined (QMPI) - use qmpi, only : qmpi_proc_num, master -#else - use qmpi_fake -#endif - implicit none - integer, intent(in) :: nx,ny ! Grid dimension - integer, intent(in) :: iens ! Ensemble member to read - real, dimension(nx,ny), intent(out) :: fld ! output fld - character(len=*), intent(in) :: memfile! base name of input files - character(len=*), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - integer, intent(in) :: vlevel ! vertical level - - real*8, dimension(nx,ny) :: readfldr8 - real*4, dimension(nx,ny) :: readfldr4 - real*4:: amin, amax,spval - real :: bmin, bmax - integer :: indx - - - ! Dette fordi is-variablane forelobig er paa gammalt format. - if (trim(cfld) /= 'icec' .and. trim(cfld) /= 'hice') then - - ! KAL - 1) f kva index som skal lesast finn vi fraa .b fil (header) - call rst_index_from_header(trim(memfile)//'.b', & ! filnavn utan extension - cfld , & ! felt som skal lesast fex saln,temp - vlevel, & ! vertikalnivaa - tlevel, & ! time level - kan vere 1 eller 2 - vi bruker 1 foreloepig - indx, & ! indexen som maa lesas fra data fila - bmin,bmax, & ! min/max - kan sjekkast mot det som er i datafila - .true. ) - - if (indx < 0) then - if (master) then - print *, 'ERROR: get_mod_fld_new(): ', trim(memfile), '.b: "',& - trim(cfld), '" not found' - end if - stop - end if - - ! KAL -- les datafelt vi fann fraa header fila (indx) - spval=0. - call READRAW(readfldr4 ,& ! Midlertidig felt som skal lesast - amin, amax ,& ! max/min fraa data (.a) fila - nx,ny ,& ! dimensjonar - .false.,spval ,& ! dette brukast for sette "no value" verdiar - trim(memfile)//'.a',& ! fil som skal lesast fraa - indx) ! index funne over - - ! Sjekk p at vi har lest rett - samanlign max/min fr filene - if (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. & - abs(bmax-amax).gt.abs(bmax)*1.e-4 ) then - print *,'Inconsistency between .a and .b files' - print *,'.a : ',amin,amax - print *,'.b : ',bmin,bmax - print *,cfld,vlevel,tlevel - print *,indx - print *,'node ',qmpi_proc_num - call exit(1) - end if - fld=readfldr4 - - else ! fld = fice, hice - - ! Gammal rutine ja - call get_mod_fld(readfldr8,iens,cfld,0,1,nx,ny) - fld=readfldr8 - end if - - - -end subroutine - - - -end module m_get_mod_fld - - diff --git a/assim/enkf_cf-system2_old/EnKF/m_insitu.F90 b/assim/enkf_cf-system2_old/EnKF/m_insitu.F90 deleted file mode 100755 index 2c4ea1f3..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_insitu.F90 +++ /dev/null @@ -1,789 +0,0 @@ -! File: m_insitu.F90 -! -! Created: 6 Feb 2008 -! -! Last modified: 13 Feb 2008 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: The code to deal with insitu observations. -! -! Description: This module contains the following subroutines: -! - insitu_setprofiles -! breaks the measurements into profiles and returns -! arrays of start and end indices for each profile -! - insitu_writeprofiles -! writes profiles to a netCDF file -! - insitu_prepareobs -! sorts out the measurements within profiles so they -! go in surface to bottom order and thins the measurements -! by keeping max 1 measurements per layer of the first -! ensemble member -! It also contains the following data: -! nprof -! - the number of profiles -! pstart(nprof) -! - start indices for each profile in the array "obs" of -! type(measurement) stored in module m_obs -! pend(nprof) -! - end indices for each profile -! -! Modifications: -! 18/03/2015 Yiguo Wang: set TEM_MIN = -2.5 and SAL_MIN = 1.0, -! which match with m_Generate_element_Si.F90 -! 21/07/2015 Yiguo Wang: added a parameter (logical) THIN -! 30/7/2010 PS: added profile pivot points to profile output -! files (SAL.nc etc.) -! 29/7/2010 PS: some rather minor changes, including interface -! of insitu_writeforecast() -! 13/02/2008 PS: added insitu_writeprofiles() -! 26/02/2008 PS: put "nprof", "pstart" and "pend" as public data -! in this module -! 20/04/2008 PS: added insitu_QC() and insitu_writeforecast() -! 29/07/2010 PS: removed insitu_QC(). There is a generic obs QC -! procedure in m_obs.F90 now. - -module m_insitu - use mod_measurement - use m_parse_blkdat - use m_get_mod_fld -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - - ! - ! public stuff - ! - integer, allocatable, dimension(:), public :: pstart - integer, allocatable, dimension(:), public :: pend - integer, public :: nprof - - public insitu_setprofiles - public insitu_prepareobs - public insitu_writeprofiles - - ! - ! private stuff - ! - - real, parameter, private :: ONEMETER = 98060.0 - integer, parameter, private :: STRLEN = 512 - - ! The portion of the layer thickness at which the variability in - ! vertical data will be used for estimating the vertical representativeness - ! error. - ! - real, parameter, private :: VARCOEFF1 = 0.15 - - ! A factor by which a calculated vertical representativeness error variance - ! will be reduced if the data is in different layers - ! - real, parameter, private :: VARCOEFF2 = 2.0 - - ! Write information about this profile. Set to < 1 to switch off. - ! - integer, parameter, private :: PDEBUGINFO = 0 - - ! Integers used to tag the fields (to avoid parsing the string tags) - ! - integer, parameter, private :: NONE = 0 - integer, parameter, private :: TEMPERATURE = 1 - integer, parameter, private :: SALINITY = 2 - - real, parameter, private :: TEM_MIN = -2.5 - real, parameter, private :: TEM_MAX = 35.0 - real, parameter, private :: SAL_MIN = 1.0 - real, parameter, private :: SAL_MAX = 41.0 - - ! Maximum allowed deviation between the observation and ensemble mean in - ! terms of combined standard deviation. - ! - real, parameter, private :: SAL_MAXRATIO = 10.0 - real, parameter, private :: TEM_MAXRATIO = 5.0 - - ! If an observation is not considered an outlier, the observation error - ! variance is modified so that the distance between the observation and the - ! endemble mean is within DIST_MAX * sqrt(sigma_obs^2 + sigma_ens^2). - ! Bigger values of DIST_MAX result in a more violent assimilation. - ! - real, parameter, private :: DIST_MAX = 2.0 - - ! Thin the profile - logical, parameter, private :: THIN = .FALSE. - -contains - - ! Work out the number of profiles, each identified by "obs % i_orig_grid" - ! and return start id of the first and the last obs in the profile in - ! arrays "pstart" and "pend". "pstart" and "pend" are publicly available - ! arrays stored in this module. - ! - subroutine insitu_setprofiles(obstag, nobs, obs) - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - type(measurement), dimension(:), intent(inout) :: obs - - integer, allocatable, dimension(:) :: tmp, tmp1 - integer :: o, o1, o2, p, nobsp - type(measurement), allocatable, dimension(:) :: tmpobs - - if (nobs == 0) then - return - end if - - if (allocated(pstart)) then - deallocate(pstart) - deallocate(pend) - end if - - ! find the very first obs of the right kind - ! - o1 = 1 - do while (trim(obs(o1) % id) /= trim(obstag) .and. o1 <= nobs) - o1 = o1 + 1 - end do - - if (o1 > nobs) then - return - end if - - ! find the very last obs of the right kind - ! - o2 = nobs - do while (trim(obs(o2) % id) /= trim(obstag) .and. o2 >= 0) - o2 = o2 - 1 - end do - - nprof = 1 - do o = o1+1, o2 - if (obs(o) % ipiv /= obs(o - 1) % ipiv .or.& - obs(o) % jpiv /= obs(o - 1) % jpiv .or.& - obs(o) % date /= obs(o - 1) % date) then - nprof = nprof + 1 - end if - end do - - allocate(pstart(nprof)) - allocate(pend(nprof)) - - ! identify profiles - ! - ! PS: This is a tricky cycle but it seems it is doing the job. Do not - ! meddle with it. - ! - pend = 0 - nprof = 1 - pstart(1) = o1 - do o = o1, o2 - ! find obs from the same profile - ! - if (trim(obs(o) % id) == trim(obstag) .and.& - ((obs(o) % i_orig_grid > 0 .and.& - obs(o) % i_orig_grid == obs(pstart(nprof)) % i_orig_grid) .or.& - (obs(o) % i_orig_grid <= 0 .and.& - obs(o) % ipiv == obs(pstart(nprof)) % ipiv .and.& - obs(o) % jpiv == obs(pstart(nprof)) % jpiv .and.& - obs(o) % date == obs(pstart(nprof)) % date))) then - pend(nprof) = o - cycle - end if - - if (trim(obs(o) % id) /= trim(obstag)) then - print *, 'ERROR: insitu_setprofiles(): obs id does not match processed obs tag' - stop - end if - - ! if there were no obs of the right type in this profile yet, - ! then pend(nprof) has not been set yet and therefore the condition - ! below will yield "false" - ! - if (pend(nprof) >= pstart(nprof)) then - nprof = nprof + 1 - end if - - if (PDEBUGINFO > 0) then - print *, ' DEBUG: new profile #', nprof, ', o =', o, ', id =', obs(o) % i_orig_grid - end if - pstart(nprof) = o - pend(nprof) = o - end do - if (pend(nprof) < pstart(nprof)) then - nprof = nprof - 1 - end if - ! truncate "pstat" and "pend" to length "nprof" - ! - allocate(tmp(nprof)) - tmp = pstart(1 : nprof) - deallocate(pstart) - allocate(pstart(nprof)) - pstart = tmp - tmp = pend(1 : nprof) - deallocate(pend) - allocate(pend(nprof)) - pend = tmp - deallocate(tmp) - - ! for glider data - sort observations in each profile by increasing depth - ! - if (trim(obstag) == 'GSAL'.or. trim(obstag) == 'GTEM') then - allocate(tmp(nobs)) - allocate(tmp1(nobs)) - allocate(tmpobs(nobs)) - do p = 1, nprof - nobsp = pend(p) - pstart(p) + 1 - do o = 1, nobsp - tmp(o) = o - end do - ! - ! (using procedure from pre_local_analysis()) - ! - call order(dble(nobsp), obs(pstart(p) : pend(p)) % depth,& - dble(nobsp), tmp, tmp1) - tmpobs(1 : nobsp) = obs(pstart(p) : pend(p)) - do o = 1, nobsp - obs(pstart(p) + o - 1) = tmpobs(tmp1(o)) - end do - end do - deallocate(tmp, tmp1, tmpobs) - end if - end subroutine insitu_setprofiles - - - ! 1. Sort out the obs within profiles so that they are stored in order of - ! increasing depth. - ! 2. Option: thin observations by keeping a single obs within a layer using the - ! layers from the first ensemble member - ! - subroutine insitu_prepareobs(obstag, nobs, obs) - character(*), intent(in) :: obstag - integer, intent(inout) :: nobs - type(measurement), dimension(:), intent(inout) :: obs - - ! profiles - ! - integer, allocatable, dimension(:) :: pnow - integer :: nobs_max - - integer :: p, o - type(measurement), allocatable, dimension(:) :: profile - - integer, allocatable, dimension(:) :: ipiv, jpiv - real, allocatable, dimension(:) :: a1, a2, a3, a4 - real, allocatable, dimension(:) :: z1, z2 - - integer :: nrev - integer :: ndel - integer :: oo - real :: rdummy - integer :: k, nk, ni, nj - character(80) :: fname - integer :: tlevel - real, allocatable, dimension(:, :) :: dz2d - real, dimension(2, 2) :: dz_cell - real :: dz, zcentre - integer :: best - logical :: isrogue - - ! As we thin the measurements within each layer, it still may be a good - ! idea to update the obs error variance if the variability within the layer - ! is big enough. `dmin' and `dmax' give the min and max measured values - ! within the layer. - ! - real :: dmin, dmax - real :: var1, var2 - - integer :: nobsnew, nobs_thistype, nobs_othertype - - if (master) then - print '(a, a, a)', ' insitu_prepareobs(', trim(obstag), '):' - print '(a, i6)', ' total # of obs = ', nobs - end if - - if (nobs == 0) then - return - end if - - call insitu_setprofiles(trim(obstag), nobs, obs) - - if (master) then - print '(a, a, a, i6)', ' # of obs of type "', trim(obstag), '" = ',& - sum(pend(1 : nprof) - pstart(1 : nprof)) + nprof - print '(a, i4)', ' # of profiles = ', nprof - end if - - ! find the maximal # of obs in a single profile - ! - nobs_max = 0 - do p = 1, nprof - nobs_max = max(nobs_max, pend(p) - pstart(p) + 1) - end do - - if (master) then - print '(a, i4)', ' max # of obs in a profile before thinning = ', nobs_max - end if - - ! reverse the obs in profiles that go from bottom to surface - ! - allocate(profile(nobs_max)) - nrev = 0 - do p = 1, nprof - if (obs(pstart(p)) % depth > obs(pend(p)) % depth) then - - profile(1 : pend(p) - pstart(p) + 1) = obs(pstart(p) : pend(p)) - do o = 0, pend(p) - pstart(p) - obs(pstart(p) + o) = profile(pend(p) - o) - end do - nrev = nrev + 1 - end if - end do - deallocate(profile) - - if (nrev > 0 .and. master) then - print *, ' ', nrev, ' profile(s) reversed' - end if - - ! check for rogue obs - ! - ndel = 0 - do p = 1, nprof - isrogue = .false. - do o = pstart(p) + 1, pend(p) - - ! shift the remaining obs in this profile one obs down - ! - if (obs(o) % depth <= obs(o - 1) % depth) then - isrogue = .true. - do oo = o + 1, pend(p) - obs(oo - 1) = obs(oo) - end do - ndel = ndel + 1 - pend(p) = pend(p) - 1 - end if - end do - if (isrogue .and. master) then - print *, ' a rogue obs detected in profile # ', p - end if - end do - - if (ndel > 0 .and. master) then - print *, ' ', ndel, 'rogue obs deleted' - end if - - ! - ! Now to the thinning of the profiles. - ! - if (THIN) then - allocate(ipiv(nprof)) - allocate(jpiv(nprof)) - allocate(a1(nprof)) - allocate(a2(nprof)) - allocate(a3(nprof)) - allocate(a4(nprof)) - - ipiv = obs(pstart(1 : nprof)) % ipiv - jpiv = obs(pstart(1 : nprof)) % jpiv - a1 = obs(pstart(1 : nprof)) % a1 - a2 = obs(pstart(1 : nprof)) % a2 - a3 = obs(pstart(1 : nprof)) % a3 - a4 = obs(pstart(1 : nprof)) % a4 - - ! get the grid dimensions - ! - call parse_blkdat('kdm ','integer', rdummy, nk) - call parse_blkdat('idm ','integer', rdummy, ni) - call parse_blkdat('jdm ','integer', rdummy, nj) - - ! get the data file name - ! - if (trim(obstag) /= 'SAL' .and. trim(obstag) /= 'TEM' .and.& - trim(obstag) /= 'GSAL'.and. trim(obstag) /= 'GTEM') then - print *, 'ERROR: insitu_prepareobs(): unknown observation tag "', trim(obstag), '"' - stop - end if - fname = 'forecast001' - - allocate(z1(nprof)) - allocate(z2(nprof)) - allocate(pnow(nprof)) - allocate(dz2d(ni, nj)) - - ! data thinning cycle - ! - if (master) then - print *, ' maximum one observation per layer will be retained after thinning' - end if - tlevel = 1 - z1 = 0.0 - pnow = pstart - if (master .and. PDEBUGINFO > 0) then - p = PDEBUGINFO - print *, 'DEBUG dumping the info for profile #', p - print *, 'DEBUG p =', p, ': lon =', obs(pstart(p)) % lon, ', lat =', obs(pstart(p)) % lat - print *, 'DEBUG now dumping the layer depths:' - end if - - ! mask all obs of this type as bad; unmask the best obs within a layer - ! - do o = 1, nobs - if (trim(obs(o) % id) == trim(obstag)) then - obs(o) % status = .false. - end if - end do - do k = 1, nk - call get_mod_fld_new(trim(fname), dz2d, 1, 'dp ', k, tlevel, ni, nj) - do p = 1, nprof - dz_cell(:, :) = dz2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1) - dz = dz_cell(1, 1) * a1(p) + dz_cell(2, 1) * a2(p)& - + dz_cell(1, 2) * a3(p) + dz_cell(2, 2) * a4(p) - dz = dz / ONEMETER - z2(p) = z1(p) + dz - zcentre = (z1(p) + z2(p)) / 2.0 - best = -1 - dmin = 1.0d+10 - dmax = -1.0d+10 - if (master .and. PDEBUGINFO > 0 .and. p == PDEBUGINFO) then - print *, 'DEBUG p =', p, ', k =', k, ', z =', z1(p), '-', z2(p) - end if - do while (pnow(p) <= pend(p)) - o = pnow(p) - - ! check that the depth is within the layer - ! - if (obs(o) % depth > z2(p)) then - ! go to next profile; this obs will be dealt with when - ! processing the next layer - exit - end if - - ! from this point on, the obs counter will be increased at the - ! end of this loop - - ! store profile and layer number (overwrite the original profile - ! id and vertical counter value) - ! - obs(o) % i_orig_grid = p - obs(o) % j_orig_grid = k - obs(o) % h = z2(p) - z1(p) - - if (obs(o) % depth < z1(p)) then - pnow(p) = pnow(p) + 1 - cycle ! next obs - end if - - ! update `dmin' and `dmax' - ! - dmin = min(dmin, obs(o) % d) - dmax = max(dmax, obs(o) % d) - - if (best < 1) then - best = o - obs(best) % status = .true. - else if (abs(obs(o) % depth - zcentre) < abs(obs(best) % depth - zcentre)) then - obs(best) % status = .false. ! thrash the previous best obs - best = o - obs(best) % status = .true. - end if - pnow(p) = pnow(p) + 1 - end do ! o - - ! update the observation error variance if the difference between - ! `dmin' and `dmax' is big enough - ! - if (best < 1) then - cycle - end if - - if (.false.) then ! out for now; use the closest obs instead - if (dmax - dmin > 0) then - obs(best) % var = sqrt(obs(best) % var + ((dmax - dmin) / 2) ** 2) - end if - end if - end do ! p - z1 = z2 - end do ! k - - ! There are a number of ways the vertical variability can be - ! used for updating the obs error variance. - ! - ! Below, the following approach is used. - ! - ! Calculate two estimates for vertical gradient using the closest data - ! points (if available). Estimate the difference at (VARCOEFF1 * h) - ! vertical distance from the current obs, where VARCOEFF1 is the portion - ! of the layer thickness (typically around 0.1-0.3), and h is the layer - ! thickness. Use the square of this difference as an estimate for the - ! respresentation error variance. If the closest obs is in another layer - ! -- decrease this estimate by a factor of VARCOEFF2 (typically around 2). - ! Use the largest estimate between the two (when both are avalaible). - ! - do p = 1, nprof - do o = pstart(p), pend(p) - k = obs(o) % j_orig_grid - if (obs(o) % status) then - var1 = -999.0 - var2 = -999.0 - if (o - 1 >= pstart(p)) then - var1 = ((obs(o) % d - obs(o - 1) % d) /& - (obs(o) % depth - obs(o - 1) % depth) * obs(o) % h * VARCOEFF1) ** 2 - if (obs(o - 1) % j_orig_grid /= k) then - var1 = var1 / VARCOEFF2 - end if - end if - if (o + 1 <= pend(p)) then - var2 = ((obs(o) % d - obs(o + 1) % d) /& - (obs(o) % depth - obs(o + 1) % depth) * obs(o) % h * VARCOEFF1) ** 2 - if (obs(o + 1) % j_orig_grid /= k) then - var2 = var2 / VARCOEFF2 - end if - end if - if (var1 < 0.0 .and. var2 < 0.0) then - cycle - end if - obs(o) % var = obs(o) % var + max(var1, var2) - end if - end do - end do - - if (master .and. PDEBUGINFO > 0) then - p = PDEBUGINFO - print *, 'DEBUG now dumping the obs info:' - do o = pstart(p), pend(p) - print *, 'DEBUG o =', o, ', status =', obs(o) % status, & - ', d =', obs(o) % d, ', z =', obs(o) % depth,& - ', k =', obs(o) % j_orig_grid, ', h =', obs(o) % h,& - ', var =', obs(o) % var - end do - end if - - deallocate(dz2d) - deallocate(pnow) - deallocate(z2) - deallocate(z1) - deallocate(a4) - deallocate(a3) - deallocate(a2) - deallocate(a1) - deallocate(jpiv) - deallocate(ipiv) - - ! now compact the obs array - ! - nobsnew = 0 - nobs_thistype = 0 - nobs_othertype = 0 - do o = 1, nobs - if (obs(o) % status) then - nobsnew = nobsnew + 1 - obs(nobsnew) = obs(o) - if (trim(obs(o) % id) == trim(obstag)) then - nobs_thistype = nobs_thistype + 1 - else - nobs_othertype = nobs_othertype + 1 - end if - end if - end do - obs(nobsnew + 1 : nobs) % status = .false. - nobs = nobsnew - - ! replace the original profiles by the thinned ones - ! - call insitu_setprofiles(trim(obstag), nobs, obs) - - if (master) then - print *, ' thinning completed:', nobs_thistype, ' "', trim(obstag), '" obs retained' - if (nobs_othertype > 0) then - print *, ' ', nobs_othertype, 'obs of other type(s) retained' - end if - end if - end if ! if(THIN) - - end subroutine insitu_prepareobs - - - ! Write profiles to a NetCDF file - ! - subroutine insitu_writeprofiles(fname, obstag, nobs, obs) - use nfw_mod - - character(*), intent(in) :: fname - character(*), intent(in) :: obstag - integer, intent(inout) :: nobs - type(measurement), dimension(:), intent(inout) :: obs - - ! profiles - ! - integer :: p - integer :: npoints, npoints_max - - ! I/O - ! - integer :: ncid - integer :: nprof_id(1), nk_id(1), dids(2) - integer :: lat_id, lon_id, ipiv_id, jpiv_id, npoints_id, depth_id, v_id, variance_id - character(STRLEN) :: varname - - real(8), allocatable, dimension(:, :) :: v - - if (.not. allocated(pstart)) then - call insitu_setprofiles(trim(obstag), nobs, obs) - end if - - call nfw_create(fname, nf_write, ncid) - - call nfw_def_dim(fname, ncid, 'nprof', nprof, nprof_id(1)) - call nfw_def_var(fname, ncid, 'lat', nf_double, 1, nprof_id, lat_id) - call nfw_def_var(fname, ncid, 'lon', nf_double, 1, nprof_id, lon_id) - call nfw_def_var(fname, ncid, 'ipiv', nf_int, 1, nprof_id, ipiv_id) - call nfw_def_var(fname, ncid, 'jpiv', nf_int, 1, nprof_id, jpiv_id) - call nfw_def_var(fname, ncid, 'npoints', nf_int, 1, nprof_id, npoints_id) - npoints_max = maxval(pend - pstart) + 1 - call nfw_def_dim(fname, ncid, 'nk', npoints_max, nk_id(1)) - dids(1) = nk_id(1) - dids(2) = nprof_id(1) - call nfw_def_var(fname, ncid, 'depth', nf_double, 2, dids, depth_id) - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then - varname = 'salt' - else if (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then - varname = 'temp' - else - varname = trim(obstag) - end if - call nfw_def_var(fname, ncid, trim(varname), nf_double, 2, dids, v_id) - call nfw_def_var(fname, ncid, 'variance', nf_double, 2, dids, variance_id) - - call nfw_enddef(fname, ncid) - - call nfw_put_var_double(fname, ncid, lat_id, obs(pstart) % lat) - call nfw_put_var_double(fname, ncid, lon_id, obs(pstart) % lon) - call nfw_put_var_int(fname, ncid, ipiv_id, obs(pstart) % ipiv) - call nfw_put_var_int(fname, ncid, jpiv_id, obs(pstart) % jpiv) - call nfw_put_var_int(fname, ncid, npoints_id, pend - pstart + 1) - - ! depth - ! - allocate(v(npoints_max, nprof)) - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = obs(pstart(p) : pend(p)) % depth - end do - call nfw_put_var_double(fname, ncid, depth_id, v) - - ! data - ! - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = obs(pstart(p) : pend(p)) % d - end do - call nfw_put_var_double(fname, ncid, v_id, v) - - ! data error variance - ! - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = obs(pstart(p) : pend(p)) % var - end do - call nfw_put_var_double(fname, ncid, variance_id, v) - - call nfw_close(fname, ncid) - - deallocate(v) - deallocate(pstart) - deallocate(pend) - end subroutine insitu_writeprofiles - - - ! This subroutine appends the interpolated ensemble mean and the ensemble - ! error variance to the assimilated profile data SAL.nc or TEM.nc. It also - ! overwrites the observation error variance with latest values. - ! - subroutine insitu_writeforecast(obstag, nobs, nrens, S, obs) - use nfw_mod - implicit none - - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - integer, intent(in) :: nrens - real, dimension(nobs, nrens), intent(in) :: S - type(measurement), dimension(nobs), intent(inout) :: obs - - character(STRLEN) :: fname - real, dimension(nobs) :: Smean, Svar - integer :: i, p - - integer :: ncid - integer :: dids(2) - integer :: v_id, variance_id - integer :: npoints_max, npoints - real(8), allocatable, dimension(:, :) :: v - - ! need to set profiles for the given observation type - ! - call insitu_setprofiles(obstag, nobs, obs) - - write(fname, '(a, ".nc")') trim(obstag) - print *, 'Appending interpolated forecast for "', trim(obstag),& - '" to "', trim(fname), '"' - - Smean = sum(S, DIM = 2) / nrens - Svar = 0.0 - do i = 1, nobs - Svar(i) = sum((S(i, :) - Smean(i)) ** 2) - end do - Svar = Svar / real(nrens - 1) - - call nfw_open(fname, nf_write, ncid) - - call nfw_inq_dimid(fname, ncid, 'nk', dids(1)) - call nfw_inq_dimid(fname, ncid, 'nprof', dids(2)) - - call nfw_redef(fname, ncid) - - call nfw_def_var(fname, ncid, 'forecast', nf_double, 2, dids, v_id) - call nfw_def_var(fname, ncid, 'forecast_variance', nf_double, 2, dids, variance_id) - - call nfw_enddef(fname, ncid) - - npoints_max = maxval(pend - pstart) + 1 - allocate(v(npoints_max, nprof)) - - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = Smean(pstart(p) : pend(p)) - end do - call nfw_put_var_double(fname, ncid, v_id, v) - - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = Svar(pstart(p) : pend(p)) - end do - call nfw_put_var_double(fname, ncid, variance_id, v) - - ! update observation error variance - ! - call nfw_redef(fname, ncid) - call nfw_rename_var(fname, ncid, 'variance', 'variance_orig') - call nfw_def_var(fname, ncid, 'variance', nf_double, 2, dids, variance_id) - call nfw_enddef(fname, ncid) - - v = -999.0 - do p = 1, nprof - npoints = pend(p) - pstart(p) + 1 - v(1 : npoints, p) = obs(pstart(p) : pend(p)) % var - end do - call nfw_put_var_double(fname, ncid, variance_id, v) - - call nfw_close(fname, ncid) - - deallocate(v) - end subroutine insitu_writeforecast - -end module m_insitu diff --git a/assim/enkf_cf-system2_old/EnKF/m_local_analysis.F90 b/assim/enkf_cf-system2_old/EnKF/m_local_analysis.F90 deleted file mode 100755 index 403e37b5..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_local_analysis.F90 +++ /dev/null @@ -1,1480 +0,0 @@ -! File: m_local_analysis.F90 -! -! Created: L. Bertino, 2002 -! -! Last modified: 13/04/2010 -! -! Purpose: Local analysis: -! -- calculation of X5 -! -- update of the ensemble fields -! -! Description: This module handles local analysis. -! -! Modifications: -! 18/07/2017 Yiguo Wang: -! - modified update_fields() for the super-DP method -! (Wang et al., 2016) -! 15/12/2016 Yiguo Wang: -! - add get_local_obs_grid() which is similar to get_local_obs(), -! but uses grid number as loc radius. -! - set max number of observations nlobs = 0 -! 18/03/2016 Yiguo Wang: -! - set max number of observations nlobs = 30 (Hamrud et -! al. 2015) -! 20/9/2011 PS: -! - modified update_fields() to allow individual inflation -! for each of `nfields' fields - thanks to Ehouarn Simon -! for spotting this inconsistency -! 25/8/2010 PS: -! - "obs" and "nobs" are now global, stored in m_obs. -! Accordingly, the local observations variables are now -! called "lobs" and "nlobs". Renamed "DD" to "D" and "d" -! to "dy". -! 5/8/2010 PS: -! - moved applying inflation from calc_X5() to -! update_fields() -! - introduced "rfactor" argument to calc_X5() - increases -! obs. error variance for the update of anomalies. -! 29/7/2010 PS: -! - calc_X5(): updated the list of things that needed to be -! done for a point with no local obs -! 6/7/2010 PS: -! - moved ij2nc() to p2nc_writeobs() in m_point2nc.F90 -! 19/6/2010 PS: -! - added X5 to the ij2nc() output -! 25/5/2010 PS: -! - modified to accommodate inflation -! - modified to calculate SRF (spread reduction factor) -! 13/4/2010 Alok Gupta: added open/close/barrier to ensure that -! X5tmp.uf exists before any node tries to access it. -! 8/4/2010 PS: replaced "X4" by "X5"; renamed "localanalysis()" -! to "update_fields()", and "pre_local_analysis()" by -! "calc_X5" -! 1/03/2010 PS: -! - Additional checks for file I/O, as the X4 read/write have -! been demonstrated to fail occasionally. A record is now -! written to X4tmp, then read back and compared until the -! two instances coincide (10 attempts max). -! 11/11/2009 PS: -! - Changed numerics. Now it is always assumed that R is -! diagonal -! - Choice of two chemes: EnKF and DEnKF (for now) -! - X4 calculated either in ens or obs space, depending on -! relation between nobs (# of local observations) and nrens -! - dfs and nobs for each (i,j) are written to enkf_diag.nc -! - if TEST = .true. then local stuff for (I,J) around -! (TEST_I, TEST_J) is dumped to enkf_,.nc -! 6/3/2008 PS: -! - in pre_local_analysis(): -! - introduced quick sort (O(n log n)) of pre-selected -! observations -! - reshuffled the interface -! - replaced output array of flags for local obs by an array -! of indices -! - in local_analysis(): -! -- unified arrays subD and subS -! -- got rid of calls to getD() -! -- used matmul() -! -- introduced localisation function -! -- eliminated X2 and V -! 2007 K. A. Liseter and Ragnhild Blikberg: -! -- MPI parallelisation - -module m_local_analysis - implicit none - - ! - ! public stuff - ! - real(4), allocatable, public :: X5(:,:,:) - real(4), allocatable, public :: X5check(:,:,:) - - public calc_X5 - public update_fields - - integer, parameter, private :: STRLEN = 512 - integer, parameter, private :: MAXITER = 10 - - integer, private :: nX5pad - real(4), allocatable, private :: X5pad(:) - - private get_npad_la - private locfun - private get_local_obs - private diag2nc - private traceprod - private get_loc_radius - private get_local_obs_grid - private data_variance - - ! - ! available localisation functions - ! - integer, parameter, private :: LOCFUN_NONE = 1 - integer, parameter, private :: LOCFUN_STEP = 2 - integer, parameter, private :: LOCFUN_GASPARI_COHN = 3 - - ! - ! used localisation function - ! - integer, private :: LOCFUN_USED = LOCFUN_GASPARI_COHN - - ! - ! available schemes - ! - integer, parameter, private :: SCHEME_ENKF = 1 - integer, parameter, private :: SCHEME_ETKF = 2 ! not implemented - integer, parameter, private :: SCHEME_DENKF = 3 - - ! - ! used scheme - ! - integer, private :: SCHEME_USED = SCHEME_DENKF - -contains - - ! This routine is called for each "field" (horizontal slab) after calcX5(). - ! It conducts the multiplication - ! E^a(i, :) = E^f(i, :) * X5(i), i = 1,...,n, - ! where n - state dimension. - ! - ! In this package the localisation is conducted only horizontally, so that - ! the local (nrens x nrens) ensemble transform matrix X5 is stored for each - ! node of the horizontal model grid. In TOPAZ4 this requires - ! 880 x 800 x 100 x 100 x 4 = 28 GB of storage on disk for "tmpX5.uf". If the - ! fileds were updated on one-by-one basis, this file would have to be read - ! (in TOPAZ4) 146 times. Therefore, the fields are updated in bunches of - ! `nfields' to reduce the load on disk. - ! - subroutine update_fields(ni, nj, nrens, nfields, nobs_array, depths, fld, infls,isdp) -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use mod_measurement - implicit none - - integer, intent(in) :: ni, nj ! size of grid - integer, intent(in) :: nrens ! size of ensemble - integer, intent(in) :: nfields ! number of 2D fields to be updated - integer, dimension(ni, nj), intent(in) :: nobs_array! number of local obs - real, dimension(ni, nj), intent(in) :: depths - real(4), dimension(ni * nj, nrens * nfields), intent(inout) :: fld ! fields - real, dimension(nfields), intent(in) :: infls ! inflation factors - logical, dimension(nfields), intent(in) :: isdp ! table of boolean is variable dp - real(4), dimension(nrens, nrens) :: X5tmp - real(4), dimension(nrens, nrens) :: IM ! inflation matrix - integer, dimension(nfields) :: assim_index ! indices of dp coupled to super-dp - real(4), dimension(nrens * nfields) :: fldtmp ! temporal copy of fields - real(4), dimension(nrens) :: tmp ! temporal update by X5 - integer :: m, i, j, f, k, n - integer :: irecl, iostatus - real(4) :: infl - - !KAL -- all nodes open for read access to temporary "X5" file - inquire(iolength = irecl) X5(1 : nrens, 1 : nrens, 1 : ni), X5pad - open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct',& - status = 'old', recl = irecl) - - do j = 1, nj - ! read X5 from disk - read(17, rec = j, iostat = iostatus) X5 - if (iostatus /= 0) then - print *, 'ERROR: local_analysis(): I/O error at reading X5, iostatus = ', iostatus - print *, 'ERROR: at j = ', j - stop - end if - - do i = 1, ni - ! skip this cell if it is on land - if (depths(i,j) <= 0.0) then - cycle - end if - - if (nobs_array(i, j) == 0 .and. all(infls == 1.0d0)) then - cycle - end if - - X5tmp = X5(:, :, i) - do m = 1, nrens - if (abs(1.0e0 - sum(X5tmp(:, m))) > 1.0e-4) then ! YW: change from 1e-5 to 1e-4 - print *, 'ERROR: detected inconsistency in X5' - print *, 'ERROR: at j = ', j, 'i = ', i - print *, 'ERROR: sum(X5(:, ', m, ') = ', sum(X5tmp(:, m)) - stop - end if - enddo - - ! ensemble transformation, in real(4) - ! - if (isdp(1)) then - ! initialisation - do k = 1, nfields - assim_index(k) = k - end do - fldtmp(:) = fld((j - 1) * ni + i, :) - - ! iterate from the bottom to the top of ocean - do f = nfields, 1, -1 - if (COUNT(fldtmp((f - 1) * nrens + 1 : f * nrens) .LT. 9806.) .GT. 0) then - - if (f .EQ. 1) GO TO 11 - - ! couple layers - fldtmp((f - 2) * nrens + 1 : (f - 1) * nrens) = & - fldtmp((f - 2) * nrens + 1 : (f - 1) * nrens) + & - fldtmp((f - 1) * nrens + 1 : f * nrens) - - ! update the indices of coupled layers - where (assim_index .EQ. assim_index(f)) - assim_index = assim_index(f - 1) - end where - cycle - end if - - ! update the super-layer by X5 - infl = infls(f) ! conversion to real(4) - if (infl /= 1.0) then - IM = - (infl - 1.0) / real(nrens, 4) - do m = 1, nrens - IM(m, m) = IM(m, m) + infl - end do - - tmp = matmul(fldtmp((f - 1) * nrens + 1 : f * nrens),& - matmul(X5tmp, IM)) - else - tmp = matmul(fldtmp((f - 1) * nrens + 1 : f * nrens), & - X5tmp) - end if - - ! check the non-negativity of the updated super-layer - if (COUNT(tmp .LT. 9806.) .LE. 0) then - ! redistribution factor,i.e. super-dp_a/super-dp_f - fldtmp((f - 1) * nrens + 1 : f * nrens ) = tmp / & - fldtmp((f - 1) * nrens + 1 : f * nrens) - else - if (f .NE. 1) then - ! couple layers - fldtmp((f - 2) * nrens + 1 : (f - 1) * nrens) = & - fldtmp((f - 2) * nrens + 1 : (f - 1) * nrens) + & - fldtmp((f - 1) * nrens + 1 : f * nrens) - - ! update the indices of coupled layers - where (assim_index .EQ. assim_index(f)) - assim_index = assim_index(f - 1) - end where - else ! f == 1 -11 n = 0 - ! find index of super layer below - do k = 2, nfields - if ((assim_index(k-1) .EQ. assim_index(1)) .and. & - (assim_index(k) .NE. assim_index(1))) then - n = assim_index(k) - exit - end if - end do - if (n .EQ. 0) then - !print *, 'Although EnKF couples all layers, it does not work.' - !stop - GOTO 12 - end if - - fldtmp(1 : nrens) = 0.0 - do k = 1, nfields - if ((assim_index(k) .EQ. assim_index(1)) .or. & - (assim_index(k) .EQ. n)) then - ! couple layers - fldtmp(1 : nrens) = & - fldtmp(1 : nrens) + fld((j - 1) * ni + i, & - (k - 1) * nrens + 1 : k * nrens) - - ! update the indices of coupled layers - assim_index(k) = assim_index(1) - else - exit - end if - end do - - ! update the super-layer by X5 - if (infl /= 1.0) then - tmp = matmul(fldtmp(1 : nrens), matmul(X5tmp, IM)) - else - tmp = matmul(fldtmp(1 : nrens), X5tmp) - end if - - ! check the non-negativity of the updated super-layer - if (COUNT(tmp .LT. 9806.) .GT. 0) then - ! need an extra layer - GO TO 11 - else - ! redistribution factor,i.e. super-DP_a/super-DP_f - fldtmp(1 : nrens) = tmp / fldtmp(1 : nrens) - end if - end if ! f /= 1 - end if - end do ! f - - ! redistribute super-layers to regular layers by the following formula, - ! DP_a = DP_f * super-DP_a / super-DP_f - do f = 1, nfields - fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) = & - fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) * & - fldtmp((assim_index(f) - 1) * nrens + 1 : assim_index(f) * nrens) - end do -12 if (0) then - print *, 'm' - end if - else - do f = 1, nfields - infl = infls(f) ! conversion to real(4) - if (infl /= 1.0) then - IM = - (infl - 1.0) / real(nrens, 4) - do m = 1, nrens - IM(m, m) = IM(m, m) + infl - end do - - fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) =& - matmul(fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens),& - matmul(X5tmp, IM)) - else - fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) =& - matmul(fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens), X5tmp) - end if - end do - end if - enddo - enddo - close(17) - end subroutine update_fields - - - ! This routine calculates X5 matrices involved in the EnKF analysis, - ! E^a(i, :) = E^f(i, :) * X5(i), i = 1,...,n, - ! where n - state dimension. - ! - ! X5(i) is calculated locally (for a given state element i) as - ! X5 = I + G s 1^T + T, - ! where - ! G = S^T (I + S S^T)^{-1} = (I + S^T S)^{-1} S^T - ! T = I - 1/2 G S (DEnKF) - ! T = I + G(D - S) (EnKF) - ! T = (I + S^T S)^{-1/2} (ETKF) - ! S = R^{-1/2} HA^f / sqrt(m - 1) - ! s = R^{-1/2} (d - Hx^f) / sqrt(m - 1) - ! - ! see Sakov et al. (2010): Asynchronous data assimilation with the EnKF, - ! Tellus 62A, 24-29. - ! - subroutine calc_X5(nrens, modlon, modlat, depths, mindx, meandx, dy, S,& - radius, rfactor, nlobs_array, ni, nj) -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use m_parameters - use distribute - use mod_measurement - use m_obs - use m_spherdist - use m_random - use m_point2nc - implicit none - - ! Input/output arguments - integer, intent(in) :: nrens - real, dimension(ni, nj), intent(in) :: modlon, modlat - real, dimension(ni, nj), intent(in) :: depths - real, intent(in) :: mindx ! min grid size - real, intent(in) :: meandx ! mean grid size - real, dimension(nobs), intent(inout) :: dy ! innovations - real, dimension(nobs, nrens), intent(inout) :: S ! HA - real, intent(in) :: rfactor ! obs. variance multiplier for anomalies - real, intent(inout) :: radius ! localisation radius in km - integer, dimension(ni, nj), intent(out) :: nlobs_array ! # of local obs - ! for each grid cell - integer, intent(in) :: ni, nj ! horizontal grid size - - real, dimension(nrens, nrens) :: X5tmp - integer, dimension(nobs) :: lobs ! indices of local observations - - real, allocatable, dimension(:,:) :: D ! observation perturbations - real, allocatable, dimension(:) :: subdy - real, allocatable, dimension(:) :: lfactors ! loc. coeffs stored for QC - real, allocatable, dimension(:,:) :: subD, subS ! nobs x nrens - real, allocatable, dimension(:,:) :: X1 ! nobs x nobs - real, allocatable, dimension(:,:) :: G - real, allocatable, dimension(:) :: x - real :: sqrtm - real :: tmp(1) - - integer :: iostatus - integer, dimension(nj):: jmap, jmap_check -#if defined (QMPI) - integer, allocatable, dimension(:, :) :: mpibuffer_int - real(4), allocatable, dimension(:, :) :: mpibuffer_float1, mpibuffer_float2 -#endif - - integer :: lapack_info - -#if defined (QMPI) - integer :: p -#endif - integer :: nlobs ! # of local obs - integer :: m, i, j, o, jj, iter - logical :: testthiscell ! test analysis at a certain cell - integer :: irecl - integer :: nlobs_max ! maximal number of local obs - real :: dist, lfactor - type(measurement) :: obs0 - - ! dfs calculation - real :: dfs - real(4) :: dfs_array(ni, nj) - ! srf calculation - real :: srf - real(4) :: srf_array(ni, nj) - - ! "partial" dfs - real :: pdfs(nuobs) - real(4) :: pdfs_array(ni, nj, nuobs) - ! "partial" srf - real :: psrf(nuobs) - real(4) :: psrf_array(ni, nj, nuobs) - ! auxiliary variables for dfs and srf calculation, such as - ! nobs for different obs types - integer :: plobs(nobs, nuobs) - integer :: pnlobs(nuobs) - integer :: uo - - if (trim(METHODTAG) == "ENKF") then - SCHEME_USED = SCHEME_ENKF - elseif (trim(METHODTAG) == "DENKF") then - SCHEME_USED = SCHEME_DENKF - end if - - if (master) then - if (SCHEME_USED == SCHEME_ENKF) then - print *, 'using EnKF analysis scheme' - elseif (SCHEME_USED == SCHEME_DENKF) then - print *, 'using DEnKF analysis scheme' - end if - end if - - if (LOCRAD > 0.0d0) then - if (trim(LOCFUNTAG) == "GASPARI-COHN"& - .or. trim(LOCFUNTAG) == "GASPARI_COHN") then - LOCFUN_USED = LOCFUN_GASPARI_COHN - elseif (trim(LOCFUNTAG) == "STEP") then - LOCFUN_USED = LOCFUN_STEP - elseif (trim(LOCFUNTAG) == "NONE") then - LOCFUN_USED = LOCFUN_NONE - end if - else - LOCFUN_USED = LOCFUN_NONE - end if - - if (master) then - if (LOCFUN_USED == LOCFUN_GASPARI_COHN) then - print *, 'using Gaspari-Cohn localisation' - elseif (LOCFUN_USED == LOCFUN_STEP) then - print *, 'using STEP localisation' - elseif (LOCFUN_USED == LOCFUN_NONE) then - print *, 'using NO localisation' - end if - end if - - sqrtm = sqrt(real(nrens) - 1.0d0) - if (SCHEME_USED == SCHEME_ENKF) then - allocate(D(nobs, nrens)) - do o = 1, nobs - call randn(nrens, D(o, :)) - D(o, :) = D(o, :) / (rfactor * sqrtm) - end do - end if - do o = 1, nobs -! S(o, :) = S(o, :) / (sqrt(obs(o) % var) * sqrtm) -! dy(o) = dy(o) / (sqrt(obs(o) % var) * sqrtm) - S(o, :) = S(o, :) / sqrtm - dy(o) = dy(o) / sqrtm - end do - - ! Distribute loops across MPI nodes - call distribute_iterations(nj) - - ! The binary file tmpX5.uf holds (ni x nj) local ensemble transform - ! matrices X5, (nrens x nrens) each. They are used for creating the - ! analysed ensemble in local_analysis(). In TOPAZ3 tmpX5.uf takes about - ! 30GB of the disk space. - ! - nX5pad = get_npad_la(nrens * nrens, ni) - allocate(X5pad(nX5pad)) - inquire(iolength = irecl) X5, X5pad - - if (master) then - open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct', status = 'unknown', recl = irecl) - ! get the necessary space on disk, before starting simultaneous writing - ! by different nodes - write(17, rec = nj) X5 - close(17) - end if -#if defined (QMPI) - call barrier() -#endif - open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct',& - status = 'old', recl = irecl) - - open(31, file = trim(JMAPFNAME), status = 'old', iostat = iostatus) - if (iostatus /= 0) then - if (master) then - print *, 'WARNING: could not open jmap.txt for reading' - print *, ' no re-mapping of grid rows performed' - end if - do j = 1, nj - jmap(j) = j - end do - else - read(31, *, iostat = iostatus) jmap - if (iostatus /= 0) then - print *, 'ERROR reading jmap.txt' - stop - end if - close(31) - jmap_check = 1 - jmap_check(jmap) = 0 - if (sum(jmap_check) /= 0) then - print *, 'ERROR: non-zero control sum for jmap =', sum(jmap_check) - stop - end if - end if - - ! main cycle (over horizontal grid cells) - ! - dfs_array = 0.0 - pdfs_array = 0.0 - srf_array = 0.0 - psrf_array = 0.0 - nlobs_array = 0 - do jj = my_first_iteration, my_last_iteration - j = jmap(jj) -! print *, 'pre_local_analysis: jj =', jj, 'j =', j - - do i = 1, ni - ! data dumping flag - testthiscell = p2nc_testthiscell(i, j) - - if (testthiscell) then - print *, 'testthiscell: depth(,', i, ',', j, ') =', depths(i, j) - end if - - if (depths(i, j) > 0.0d0) then - nlobs = 0 - call get_loc_radius(modlat(i,j), radius) - call get_local_obs(i, j, radius * 1000.0, modlon, modlat,& - mindx, ni, nj, nlobs, lobs) - nlobs_array(i, j) = nlobs - else - nlobs = 0 - end if - - if (testthiscell) then - print *, 'testthiscell: nlobs(,', i, ',', j, ') =', nlobs - end if - - if (nlobs == 0) then - ! just in case - X5(:, :, i) = 0.0 - X5tmp = 0.0d0 - do m = 1, nrens - X5(m, m, i) = 1.0 - X5tmp(m, m) = 1.0d0 - enddo - if (testthiscell) then - call p2nc_writeobs(i, j, nlobs, nrens, X5tmp, modlon(i, j),& - modlat(i, j), depths(i, j)) - end if - dfs_array(i, j) = 0.0 - pdfs_array(i, j, :) = 0.0 - srf_array(i, j) = 0.0 - psrf_array(i, j, :) = 0.0 - cycle - end if - - if (nlobs < 0) then ! an extra check on the C-Fortran interface - print *, 'ERROR: nlobs =', nlobs, ' for i, j =', i, j - stop - end if - - ! Allocate local arrays - if (SCHEME_USED == SCHEME_ENKF) then - allocate(subD(nlobs, nrens)) - end if - allocate(subdy(nlobs)) - allocate(lfactors(nlobs)) - allocate(subS(nlobs, nrens)) - ! ( BTW subS1 = subS / sqrt(rfactor) ) - allocate(G(nrens, nlobs)) - if (nlobs < nrens) then - allocate(X1(nlobs, nlobs)) - else - allocate(X1(nrens, nrens)) - end if - - if (SCHEME_USED == SCHEME_ENKF) then - subD = D(lobs(1 : nlobs), :) - end if - subS = S(lobs(1 : nlobs), :) - subdy = dy(lobs(1 : nlobs)) - if (testthiscell) then - print *, 'SubS before', i, ',', j, ') =', nlobs,SubS(nlobs,:) - print *, 'S before', i, ',', j, ') =', nlobs,S(lobs(nlobs),:) - end if - - - ! taper ensemble observation anomalies and innovations - ! - if (LOCFUN_USED /= LOCFUN_NONE) then - do o = 1, nlobs - obs0 = obs(lobs(o)) - dist = spherdist(modlon(i, j), modlat(i, j),& - obs0 % lon, obs0 % lat) - call get_loc_radius(modlat(i,j), radius) - lfactor = locfun(dist / radius / 1000.0) - subS(o, :) = subS(o, :) * sqrt(lfactor) - subdy(o) = subdy(o) * sqrt(lfactor) - lfactors(o) = sqrt(lfactor) - - if (SCHEME_USED == SCHEME_ENKF) then - subD(o, :) = subD(o, :) * sqrt(lfactor) - end if - end do - else - lfactors = 1 - end if - - ! obs num dependent rfactor1 - ! - do o = 1, nlobs - obs0 = obs(lobs(o)) - if (trim(obs0 % id) .eq. 'TEM' .or. trim(obs0 % id) .eq. 'SAL') then - call data_variance(trim(obs0 % id), obs0 % depth, tmp(1)) - subS(o, :) = subS(o, :) / sqrt(max(0.1*sum(lfactors(1:nlobs - 1)) * obs0 % var + (1 - 0.1*sum(lfactors(1:nlobs - 1))) * tmp(1), obs0 % var)) - subdy(o) = subdy(o) / sqrt(max(0.1*sum(lfactors(1:nlobs - 1)) * obs0 % var + (1 - 0.1*sum(lfactors(1:nlobs - 1))) * tmp(1), obs0 % var)) -!!$ subS(o, :) = subS(o, :) / sqrt(max((nlobs - 1) * obs0 % var + (2 - nlobs) * tmp(1), obs0 % var)) -!!$ subdy(o) = subdy(o) / sqrt(max((nlobs - 1) * obs0 % var + (2 - nlobs) * tmp(1), obs0 % var)) - else - subS(o, :) = subS(o, :) / sqrt(obs0 % var) - subdy(o) = subdy(o) / sqrt(obs0 % var) - end if - end do - - if (testthiscell) then - print *, 'SubS after', i, ',', j, ') =', SubS(nlobs,:) - print *, 'locfun', dist, radius/1000., modlon(i, j), obs0 % lon, modlat(i, j),obs0 % lat - end if - - ! first iteration - with rfactor = 1, for the update of the mean - ! secons iteration - with the specified rfactor for the update of - ! the anomalies - ! - do iter = 1,2 - if (iter == 2) then - if (rfactor == 1.0d0) then - go to 10 - end if - subS = subS / sqrt(rfactor) - end if - - if (nlobs < nrens) then ! use observation space - ! Construct matrix (S * S' + I) - to be inverted - ! - X1 = matmul(subS, transpose(subS)) - do o = 1, nlobs - X1(o, o) = X1(o, o) + 1.0d0 - end do - - ! Inversion via Cholesky decomposition, done in two stages. - ! - call dpotrf('U', nlobs, X1, nlobs, lapack_info) - if (lapack_info /= 0) then - print *, ' ERROR: m_local_analysis(): LAPACK error in dpotrf: errno = '& - , lapack_info, 'i, j =', i, j - stop - endif - - call dpotri('U', nlobs, X1, nlobs, lapack_info) - if (lapack_info /= 0) then - print *, ' ERROR: m_local_analysis(): LAPACK error in dpotri: errno = '& - , lapack_info, 'i, j =', i, j - stop - endif - - ! fill the lower triangular part of (symmetric) X1 - ! - do o = 2, nlobs - X1(o, 1 : o - 1) = X1(1 : o - 1, o) - end do - - G = matmul(transpose(subS), X1) - else ! nlobs >= nrens: use ensemble space - X1 = matmul(transpose(subS), subS) - do m = 1, nrens - X1(m, m) = X1(m, m) + 1.0d0 - end do - - ! Inversion - ! - call dpotrf('U', nrens, X1, nrens, lapack_info) - if (lapack_info /= 0) then - print *, ' ERROR: m_local_analysis(): LAPACK error in dpotrf: errno = '& - , lapack_info, 'i, j =', i, j - stop - endif - call dpotri('U', nrens, X1, nrens, lapack_info) - if (lapack_info /= 0) then - print *, ' ERROR: m_local_analysis(): LAPACK error in dpotri: errno = '& - , lapack_info, 'i, j =', i, j - stop - endif - - do m = 2, nrens - X1(m, 1 : m - 1) = X1(1 : m - 1, m) - end do - - G = matmul(X1, transpose(subS)) - end if - - if (iter == 1) then - do m = 1, nrens - X5tmp(m, :) = sum(G(m, :) * subdy(:)) - end do - end if - - 10 continue - - ! calculate DFS at iteration 1, SRF at iteration 2 - ! - if (iter == 1) then - dfs = traceprod(G, subS, nrens, nlobs) - dfs_array(i, j) = real(dfs, 4) - pnlobs = 0 - do uo = 1, nuobs - do o = 1, nlobs - if (lobs(o) >= uobs_begin(uo) .and.& - lobs(o) <= uobs_end(uo)) then - pnlobs(uo) = pnlobs(uo) + 1 - plobs(pnlobs(uo), uo) = o - end if - end do - end do - pdfs = 0.0d0 - psrf = 0.0d0 - do uo = 1, nuobs - if (pnlobs(uo) > 0) then - pdfs(uo) = traceprod(G(:, plobs(1 : pnlobs(uo), uo)),& - subS(plobs(1 : pnlobs(uo), uo), :), nrens, pnlobs(uo)) - end if - pdfs_array(i, j, uo) = real(pdfs(uo), 4) - end do - else - if (dfs /= 0.0d0) then - srf = sqrt(traceprod(subS, transpose(subS), nlobs, nrens)& - / traceprod(G, subS, nrens, nlobs)) - 1.0d0 - else - srf = 0.0d0 - end if - srf_array(i, j) = real(srf, 4) - do uo = 1, nuobs - if (pnlobs(uo) > 0) then - if (pdfs(uo) /= 0.0d0) then - psrf(uo) = sqrt(& - traceprod(subS(plobs(1 : pnlobs(uo), uo), :),& - transpose(subS(plobs(1 : pnlobs(uo), uo), :)),& - pnlobs(uo), nrens) /& - traceprod(G(:, plobs(1 : pnlobs(uo), uo)),& - subS(plobs(1 : pnlobs(uo), uo), :),& - nrens, pnlobs(uo))) - 1.0d0 - else - psrf(uo) = 0.0d0 - end if - end if - psrf_array(i, j, uo) = real(psrf(uo), 4) - end do - end if - end do ! iter - - if (SCHEME_USED == SCHEME_ENKF) then - X5tmp = X5tmp + matmul(G, subD - subS) - elseif (SCHEME_USED == SCHEME_DENKF) then - X5tmp = X5tmp - 0.5d0 * matmul(G, subS) - end if - do m = 1, nrens - X5tmp(m, m) = X5tmp(m, m) + 1.0d0 - enddo - - if (testthiscell) then - ! ensemble mean - allocate(x(nlobs)) - do o = 1, nlobs - x(o) = obs(lobs(o)) % d - dy(lobs(o)) * sqrtm * sqrt(obs(lobs(o)) % var) - end do - tmp(1) = rfactor - call p2nc_writeobs(i, j, nlobs, nrens, X5tmp, modlon(i, j),& - modlat(i, j), depths(i, j), tmp(1), lobs(1 : nlobs), & - obs(lobs(1 : nlobs)), x, subS, subdy, lfactors) - deallocate(x) - end if - - ! Put X5tmp into the final X5 matrix - to be written to a file - ! - X5(:, :, i) = real(X5tmp, 4) - - deallocate(subS, subdy, lfactors, X1, G) - if (SCHEME_USED == SCHEME_ENKF) then - deallocate(subD) - end if - end do ! i = 1, ni - - ! Write one "stripe" of the temporary matrix X5 to disk - iter = 0 - do while (.true.) - iter = iter + 1 - write(17, rec = j, iostat = iostatus) X5 - if (iostatus /= 0) then - print *, 'ERROR: pre_local_analysis(): I/O error at writing X5, iostatus = ',& - iostatus - print *, 'ERROR: at model line j =', j, ' counter jj = ', jj, 'iter =', iter - if (iter < MAXITER) then - cycle - else - print *, 'ERROR: max number of iterations reached, STOP' - stop - end if - end if - read(17, rec = j, iostat = iostatus) X5check - if (iostatus /= 0) then - print *, 'ERROR: pre_local_analysis(): I/O error at reading X5, iostatus = ',& - iostatus - print *, 'ERROR: at j = ', j, ' jj = ', jj, 'iter =', iter - if (iter < MAXITER) then - cycle - else - print *, 'ERROR: max number of iterations reached, STOP' - stop - end if - end if - if (abs(maxval(X5 - X5check)) > 1.0e-6) then - print *, 'ERROR: pre_local_analysis: inconsistency between written/read X5' - print *, 'ERROR: j = ', j, ' jj = ', jj, 'iter =', iter,& - ' maxval(X5 - X5check) =', maxval(X5 - X5check) - if (iter < MAXITER) then - cycle - else - print *, 'ERROR: max number of iterations reached, STOP' - stop - end if - end if - exit ! OK - end do -! print *, 'FINISHED j =', j, ' jj =', jj - end do ! j = my_first_iteration, my_last_iteration - - close(17) ! X5 file - - if (SCHEME_USED == SCHEME_ENKF) then - deallocate(D) - end if - -#if defined(QMPI) - if (.not. master) then - ! broadcast nlobs and dfs arrays to master - call send(nlobs_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 0) - call send(dfs_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 1) - call send(srf_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 1) - allocate(mpibuffer_float1(ni, my_last_iteration - my_first_iteration + 1)) - allocate(mpibuffer_float2(ni, my_last_iteration - my_first_iteration + 1)) - do uo = 1, nuobs - mpibuffer_float1 = pdfs_array(:, jmap(my_first_iteration : my_last_iteration), uo) - call send(mpibuffer_float1, 0, uo + 1) - mpibuffer_float2 = psrf_array(:, jmap(my_first_iteration : my_last_iteration), uo) - call send(mpibuffer_float2, 0, uo + 1) - end do - deallocate(mpibuffer_float1) - deallocate(mpibuffer_float2) - else - ! receive nlobs and dfs arrays - do p = 2, qmpi_num_proc - ! - ! PS: Ideally, it would be nice to be able to use a simple code like: - ! - ! call receive(nlobs_array(& - ! jmap(first_iteration(p) : last_iteration(p))), p - 1) - ! - ! but this seems not to work, at least with the PGI compiler. - ! Perhaps, this is too much to expect from a call to a C function... - ! The good news is that using a temporal array works fine. - ! - allocate(mpibuffer_int(ni, last_iteration(p) - first_iteration(p) + 1)) - call receive(mpibuffer_int, p - 1, 0) - nlobs_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_int - deallocate(mpibuffer_int) - allocate(mpibuffer_float1(ni, last_iteration(p) - first_iteration(p) + 1)) - call receive(mpibuffer_float1, p - 1, 1) - dfs_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_float1 - allocate(mpibuffer_float2(ni, last_iteration(p) - first_iteration(p) + 1)) - call receive(mpibuffer_float2, p - 1, 1) - srf_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_float2 - do uo = 1, nuobs - call receive(mpibuffer_float1, p - 1, uo + 1) - pdfs_array(:, jmap(first_iteration(p) : last_iteration(p)), uo) = mpibuffer_float1 - call receive(mpibuffer_float2, p - 1, uo + 1) - psrf_array(:, jmap(first_iteration(p) : last_iteration(p)), uo) = mpibuffer_float2 - end do - deallocate(mpibuffer_float1) - deallocate(mpibuffer_float2) - enddo - endif - ! broadcast nlobs array - call broadcast(nlobs_array) -#endif - - if (master) then - nlobs_max = maxval(nlobs_array) - print *, 'maximal # of local obs =', nlobs_max,& - ' reached for', count(nlobs_array == nlobs_max), 'grid cells' - print *, 'average #(*) of local obs =', sum(nlobs_array(:, 1 : nj)) / real(count(nlobs_array(:, 1 : nj) > 0)) - print *, ' * over cells with non-zero number of local obs only' - print *, 'localisation function of type', LOCFUN_USED, 'has been used' - print *, 'analysis conducted in obs space in', count(nlobs_array(:, 1 : nj) > 0 .and. nlobs_array(:, 1 : nj) < nrens),& - 'cells' - print *, 'analysis conducted in ens space in', count(nlobs_array(:, 1 : nj) >= nrens),& - 'cells' - print *, 'maximal DFS =', maxval(dfs_array) - print *, 'average(*) DFS =', sum(dfs_array) / real(count(dfs_array > 0)) - print *, ' * over cells with non-zero number of local obs only' - print *, '# of cells with DFS > N / 2 =', count(dfs_array > real(nrens / 2, 4)) - - call diag2nc(ni, nj, modlon, modlat, nlobs_array, dfs_array, pdfs_array,& - srf_array, psrf_array) - end if - end subroutine calc_X5 - - - integer function get_npad_la(ni, nj) - integer, intent(in) :: ni, nj - - get_npad_la = 4096 - mod(ni * nj, 4096) - get_npad_la = mod(get_npad_la, 4096) - end function get_npad_la - - - real function locfun(x) - real, intent(in) :: x - - real :: xx, xx2, xx3 - - select case(LOCFUN_USED) - - case (LOCFUN_NONE) - locfun = 1.0 - case (LOCFUN_STEP) - if (x > 1.0) then - locfun = 0.0 - else - locfun = 1.0 - end if - case (LOCFUN_GASPARI_COHN) - if (x > 1.0) then - locfun = 0.0 - else - xx = x * 2.0 - xx2 = xx * xx - xx3 = xx2 * xx - if (xx < 1.0) then - locfun = 1.0 + xx2 * (- xx3 / 4.0 + xx2 / 2.0)& - + xx3 * (5.0 / 8.) - xx2 * (5.0 / 3.0) - else - locfun = xx2 * (xx3 / 12.0 - xx2 / 2.0)& - + xx3 * (5.0 / 8.0) + xx2 * (5.0 / 3.0)& - - xx * 5.0 + 4.0 - (2.0 / 3.0) / xx - end if - locfun = max(locfun, 0.0) - end if - case default - print *, 'ERROR: m_local_analysis.F90: locfun(): LOCFUN_USED =', LOCFUN_USED, 'is unknown' - stop - end select - end function locfun - - - ! - Sort observations by their distance to the given grid point (i, j). - ! - Identify observations within a given radius `rmax'. - ! - Select `nlobs' nearest observations; update `nlobs' if there are not - ! enough observations within the radius. - ! - ! Note that because all observations are parsed for each 2D grid point, this - ! subroutine may become a bottleneck if the total number of observations - ! grows substantially from the current point... If this happens, we may - ! consider putting all observations in a K-D tree like in Szyonykh et. al - ! (2008), A local ensemble transform Kalman filter data assimilation system - ! for the NCEP global model (2008). Tellus 60A, 113-130. - ! - subroutine get_local_obsold(i, j, rmax, modlon, modlat, mindx,& - ni, nj, nlobs, lobs) - use mod_measurement - use m_obs - use m_spherdist - - implicit none - integer, intent(in) :: i, j - real, intent(in) :: rmax ! maximal allowed distance - real, intent(in) :: modlon(ni, nj) - real, intent(in) :: modlat(ni, nj) - real, intent(in) :: mindx - integer, intent(in) :: ni, nj - integer, intent(inout) :: nlobs ! input : max allowed # of local obs - ! output: actual # of local obs for this - ! point - integer, intent(out) :: lobs(nobs) ! indices of local observations - - integer :: ngood, nsst, nssh - integer :: sorted(nobs) - real :: dist(nobs) - integer :: o - real :: rmax2 - - lobs = 0 - ngood = 0 - rmax2 = (rmax / mindx) ** 2 - do o = 1, nobs - if (trim(obs(o) % id) .eq. 'TEM' .or. trim(obs(o) % id) .eq. 'SAL') then - if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2 ) then - cycle - end if - dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j)) - if (dist(o) < rmax) then - ngood = ngood + 1 - lobs(ngood) = o - end if - end if - end do - if (ngood > 5000) then - call order(dble(nobs), dist, dble(ngood), lobs, sorted) - lobs(1 : 5000) = sorted(1 : 5000) - ngood = 5000 - end if - - - do o = 1, nobs - if (trim(obs(o) % id) .eq. 'ICEC' ) then - if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2 ) then - cycle - end if - dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j)) - if (dist(o) < rmax) then - ngood = ngood + 1 - lobs(ngood) = o - end if - end if - end do - if (ngood > 10) then - call order(dble(nobs), dist, dble(ngood), lobs, sorted) - lobs(1 : 10) = sorted(1 : 10) - ngood = 10 - end if - - - ! only one SST - nsst = 0 - do o = 1, nobs - if (trim(obs(o) % id) .eq. 'SST') then - if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2 ) then - cycle - end if - dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j)) - if (dist(o) < rmax .and. (nsst == 0)) then - ngood = ngood + 1 - lobs(ngood) = o - nsst = 1 - else if (dist(o) < dist(lobs(ngood)) .and. (nsst == 1)) then - lobs(ngood) = o - end if - end if - end do - - ! only one SSH - nssh = 0 - do o = 1, nobs - if (trim(obs(o) % id) .eq. 'SSH') then - if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2 ) then - cycle - end if - dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j)) - if (dist(o) < rmax .and. (nssh == 0)) then - ngood = ngood + 1 - lobs(ngood) = o - nssh = 1 - else if (dist(o) < dist(lobs(ngood)) .and. (nssh == 1)) then - lobs(ngood) = o - end if - end if - end do - - if (nlobs <= 0 .or. nlobs >= ngood) then - ! - ! use all observations within localisation support radius - ! - nlobs = ngood - else - ! - ! use `nlobs' closest observations - ! - call order(dble(nobs), dist, dble(ngood), lobs, sorted) - lobs(1 : nlobs) = sorted(1 : nlobs) - end if - - end subroutine get_local_obsold - - - - - subroutine get_local_obs(i, j, rmax, modlon, modlat, mindx,& - ni, nj, nlobs, lobs) - use mod_measurement - use m_obs - use m_spherdist - - implicit none - integer, intent(in) :: i, j - real, intent(in) :: rmax ! maximal allowed distance - real, intent(in) :: modlon(ni, nj) - real, intent(in) :: modlat(ni, nj) - real, intent(in) :: mindx - integer, intent(in) :: ni, nj - integer :: o - real :: rmax2 - !ALL - integer, intent(inout) :: nlobs ! input : max allowed # of local obs - ! output: actual # of local obs for this - ! point - integer, intent(out) :: lobs(nobs) ! indices of local observations - integer :: ngood - integer :: sorted(nobs) - real :: dist(nobs) - - !===OBSTYPES - !ICEC - integer :: lobs_ice(nobs), sorted_ice(nobs) - real :: dist_ice(nobs) - integer :: nicec - integer :: nicec_max - - !PROFILE - integer :: lobs_pro(nobs), sorted_pro(nobs) - real :: dist_pro(nobs) - integer :: npro - integer :: npro_max - - !SSH, SST: only 1 obs - integer :: lobs_ssh, sorted_ssh - integer :: lobs_sst, sorted_sst - integer :: nsst, nssh - - - nicec_max=10 !=== max # obs for ICEC - npro_max =5000 !=== max # obs for TEMP and SAL profiles - - lobs = 0 - lobs_ice = 0 - lobs_pro = 0 - lobs_ssh = 0 - lobs_sst = 0 - - ngood = 0 - npro = 0 - nssh = 0 - nsst = 0 - nicec = 0 - - - rmax2 = (rmax / mindx) ** 2 -!============================================================================================== - - ! for each type: - ! if within radius: store the element index in lobs_type, count: ntype, - ! sort those via distance function and - ! store the min(ntype_max,ntype) closest in lobs - - - - !collect all of type TYPE in lobs_TYPE and count with nTYPE - do o = 1, nobs - if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2 ) then !MK: might be cheaper entirely than using spherdist - cycle - end if - - dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j)) - if (dist(o) < rmax) then - if (trim(obs(o) % id) .eq. 'TEM' .or. trim(obs(o) % id) .eq. 'SAL') then - npro = npro +1 - lobs_pro (npro) = o - dist_pro (o) = dist(o) - elseif (trim(obs(o) % id) .eq. 'ICEC') then - nicec = nicec+1 - lobs_ice(nicec) = o - dist_ice(o) = dist(o) - elseif (trim(obs(o) % id) .eq. 'SSH') then - if (nssh == 0) then - lobs_ssh = o - nssh = 1 - elseif (dist(o) < dist(lobs_ssh) .and. (nssh == 1)) then - lobs_ssh = o - endif - elseif (trim(obs(o) % id) .eq. 'SST') then !check: could be we need also as many obs as for ICEC - - if (nsst == 0) then - lobs_sst = o - nsst = 1 - elseif (dist(o) < dist(lobs_sst) .and. (nsst == 1)) then - lobs_sst = o - endif - else - print *, 'ERROR (get_local_obs): INVALID OBSERVATION TYPE' - stop - end if - end if - end do - - - !order and store nTYPE_max nearest in lobs - ! update ngood - !PROFILES - !== checked, gives bit identical results than EnKK-official - if (npro>npro_max) then - ngood = ngood+1 - call order(dble(nobs), dist_pro , dble(npro), lobs_pro, sorted_pro) - lobs(ngood : ngood+npro_max-1) = sorted_pro(1 : npro_max) - ngood = ngood+npro_max-1 - elseif (npro>0) then - ngood = ngood+1 - lobs(ngood : ngood+npro-1) = lobs_pro(1 : npro) - ngood = ngood+npro-1 - end if - - !ICEC - if (nicec>nicec_max) then - call order(dble(nobs), dist_ice, dble(nicec), lobs_ice, sorted_ice) - ngood = ngood +1 - lobs(ngood : ngood+nicec_max-1) = sorted_ice(1 : nicec_max) - ngood = ngood+nicec_max-1 - elseif (nicec>0) then - ngood = ngood +1 - lobs(ngood : ngood+nicec-1) = lobs_ice(1 :nicec) - ngood = ngood+nicec-1 - end if - - !SSH - if (nssh>0) then - ngood = ngood +1 - lobs(ngood) = lobs_ssh - end if - !SST - if (nsst>0) then - ngood = ngood +1 - lobs(ngood) = lobs_sst - end if - - -!============================================================================================== - - - if (nlobs <= 0 .or. nlobs >= ngood) then - ! - - ! use all observations within localisation support radius - ! - nlobs = ngood - else - ! - - ! use `nlobs' closest observations - ! - call order(dble(nobs), dist, dble(ngood), lobs, sorted) - lobs(1 : nlobs) = sorted(1 : nlobs) - end if - - - end subroutine get_local_obs - - - - - - ! The functionality is similar to get_local_obs(). But the distance - ! is estimated by grids. - ! - subroutine get_local_obs_grid(i, j, rmax, ni, nj, nlobs, lobs) - use mod_measurement - use m_obs - - implicit none - integer, intent(in) :: i, j - real, intent(in) :: rmax ! maximal allowed distance - integer, intent(in) :: ni, nj - integer, intent(inout) :: nlobs ! input : max allowed # of local obs - ! output: actual # of local obs for this - ! point - integer, intent(out) :: lobs(nobs) ! indices of local observations - - integer :: ngood - integer :: sorted(nobs) - real :: dist(nobs) - integer :: o - real :: rmax2 - - lobs = 0 - ngood = 0 - rmax2 = rmax ** 2 - do o = 1, nobs - if (min(abs(obs(o) % ipiv - i), ni - abs(obs(o) % ipiv - i)) ** 2 & - + (obs(o) % jpiv - j) ** 2 > rmax2 ) then - cycle - end if - dist(o) = min(abs(obs(o) % ipiv - i), ni - abs(obs(o) % ipiv - i)) ** 2 & - + (obs(o) % jpiv - j) ** 2 - dist(o) = sqrt(dist(o)) - ngood = ngood + 1 - lobs(ngood) = o - end do - - if (nlobs <= 0 .or. nlobs >= ngood) then - ! - ! use all observations within localisation support radius - ! - nlobs = ngood - else - ! - ! use `nlobs' closest observations - ! - call order(dble(nobs), dist, dble(ngood), lobs, sorted) - lobs(1 : nlobs) = sorted(1 : nlobs) - end if - - end subroutine get_local_obs_grid - - ! This subroutine writes (1) the number of local observations, (2) - ! the number of degrees of freedom of signal (DFS), and (3) spread reduction - ! factor (SRF) to file "enkf_diag.nc" - ! - subroutine diag2nc(ni, nj, lon, lat, nlobs_array, dfs_array, pdfs_array, & - srf_array, psrf_array) - use mod_measurement - use m_obs - use nfw_mod - implicit none - - integer, intent(in) :: ni - integer, intent(in) :: nj - real, intent(in) :: lon(ni, nj) - real, intent(in) :: lat(ni, nj) - integer, intent(in) :: nlobs_array(ni, nj) - real(4), intent(in) :: dfs_array(ni, nj) - real(4), intent(in) :: pdfs_array(ni, nj, nuobs) - real(4), intent(in) :: srf_array(ni, nj) - real(4), intent(in) :: psrf_array(ni, nj, nuobs) - - character(STRLEN) :: fname - character(STRLEN) :: varname - integer :: ncid - integer :: dimids(2) - integer :: lon_id, lat_id, nlobs_id, dfs_id, pdfs_id(nuobs), srf_id,& - psrf_id(nuobs) - integer :: uo - - fname = 'enkf_diag.nc' - call nfw_create(fname, nf_clobber, ncid) - - call nfw_def_dim(fname, ncid, 'i', ni, dimids(1)) - call nfw_def_dim(fname, ncid, 'j', nj, dimids(2)) - call nfw_def_var(fname, ncid, 'lon', nf_float, 2, dimids, lon_id) - call nfw_def_var(fname, ncid, 'lat', nf_float, 2, dimids, lat_id) - call nfw_def_var(fname, ncid, 'nobs', nf_int, 2, dimids, nlobs_id) - call nfw_def_var(fname, ncid, 'dfs', nf_float, 2, dimids, dfs_id) - do uo = 1, nuobs - write(varname, '(a, a)') 'dfs_', trim(unique_obs(uo)) - call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dimids, pdfs_id(uo)) - end do - call nfw_def_var(fname, ncid, 'srf', nf_float, 2, dimids, srf_id) - do uo = 1, nuobs - write(varname, '(a, a)') 'srf_', trim(unique_obs(uo)) - call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dimids, psrf_id(uo)) - end do - call nfw_enddef(fname, ncid) - - call nfw_put_var_double(fname, ncid, lon_id, lon) - call nfw_put_var_double(fname, ncid, lat_id, lat) - call nfw_put_var_int(fname, ncid, nlobs_id, nlobs_array) - call nfw_put_var_real(fname, ncid, dfs_id, dfs_array) - call nfw_put_var_real(fname, ncid, srf_id, srf_array) - do uo = 1, nuobs - call nfw_put_var_real(fname, ncid, pdfs_id(uo), pdfs_array(:, :, uo)) - call nfw_put_var_real(fname, ncid, psrf_id(uo), psrf_array(:, :, uo)) - end do - call nfw_close(fname, ncid) - end subroutine diag2nc - - - ! Calculates the trace of a product of two matrices. (Does not calculate - ! the off-diagonal elements in the process.) - ! - real function traceprod(A, B, n, m) - real, intent(in) :: A(n, m), B(m, n) - integer, intent(in) :: n, m - - integer :: i - - traceprod = 0.0d0 - do i = 1, n - traceprod = traceprod + sum(A(i, :) * B(:, i)) - end do - end function traceprod - - ! Calcaulte the localisation radius varying with latitude. - ! Bi-normal mode. lat in [-90, 90] - ! - subroutine get_loc_radius(lat, rloc) - real, intent(in ) :: lat - real, intent(out) :: rloc - - real :: t, s - - t = 2300 - s = 1400 - rloc = t*exp(-(lat + 40)**2/s) + t*exp(-(lat - 40)**2/s) - end subroutine get_loc_radius - - ! Define the observation error variance as in Xie and Zhu, 2010 - ! - subroutine data_variance(obstype, depth, var) - - implicit none - - character(*), intent(in) :: obstype - real , intent(in) :: depth - - real, intent(inout) :: var - - if (trim(obstype) == 'TEM') then - var = 0.05 + 0.45 * exp(-0.002 * depth) - var = var ** 2.0 - elseif(trim(obstype) == 'SAL') then - var = 0.02 + 0.10 * exp(-0.008 * depth) - var = var ** 2.0 - else - print *, 'ERROR: data_variance(): the definition of variance is only available for and ' - print *, obstype - stop - end if - end subroutine data_variance -end module m_local_analysis diff --git a/assim/enkf_cf-system2_old/EnKF/m_obs.F90 b/assim/enkf_cf-system2_old/EnKF/m_obs.F90 deleted file mode 100755 index 18c82fba..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_obs.F90 +++ /dev/null @@ -1,329 +0,0 @@ -! File: m_obs.F90 -! -! Created: 6 Feb 2008 -! -! Last modified: 21 Feb 2008 -! -! Author: Pavel Sakov* -! NERSC -! -! Purpose: Generic code to deal with observations. -! -! Description: This module contains the following functions and subroutines: -! - obs_setobs -! reads the observations into allocatable array obs(nobs) -! of type(measurement) -! - obs_prepareobs -! conducts state-dependent pre-processing of observations -! - obs_prepareuobs -! conducts state-dependent pre-processing of observations -! of a given type -! It also contains the following data: -! - obs -! allocatable array of type(measurement) -! - nobs -! number of observations (may differ from the size of the -! array) -! -! * This file contains some modified code of unknown origin -! from EnKF package. In particular, the code here supersedes -! the code from: -! m_get_nrobs_d.F90 -! m_get_obs_d.F90 -! -! Modifications: -! 29/07/2016 YW: -! -- add ANOMALY option for thresholds -! 29/07/2010 PS: -! -- modified obs_QC(). The maximal increment now does not go to -! 0 as the innovation increases, but rather is limited by -! KMAX * sigma_ens -! 29/06/2010 PS: -! -- added obs_QC() -! 26/02/2008 PS: -! -- put "obs" and "nobs" as public data in this module - -module m_obs -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use mod_measurement - use m_uobs - use m_insitu - implicit none - - ! - ! public stuff - ! - - integer, public :: nobs = -1 - type(measurement), allocatable, dimension(:), public :: obs - - public obs_readobs - public obs_prepareobs - public obs_QC - - ! - ! private stuff - ! - - private obs_testrange - - integer, parameter, private :: STRLEN = 512 - - real, parameter, private :: TEM_MIN = -2.0d0 - real, parameter, private :: TEM_MAX = 50.0d0 - real, parameter, private :: SAL_MIN = 2.0d0 - real, parameter, private :: SAL_MAX = 40.0d0 - real, parameter, private :: SSH_MIN = -3.0d0 - real, parameter, private :: SSH_MAX = 3.0d0 - real, parameter, private :: ICEC_MIN = 0.0d0 - real, parameter, private :: ICEC_MAX = 0.996d0 - real, parameter, private :: UVICE_MIN = -100.0 - real, parameter, private :: UVICE_MAX = 100.0 - - private obs_prepareuobs, obs_realloc - -contains - - ! Obtain observations to be used for assimilation from the file - ! "observation.uf". Store the number of observations in "nobs" and the data - ! in the array "obs". - ! - subroutine obs_readobs - use m_parameters - - logical :: exists = .false. - type(measurement) :: record - integer :: rsize - integer :: ios - integer :: o - - if (nobs >= 0) then - return - end if - - inquire(file = 'observations.uf', exist = exists) - if (.not. exists) then - if (master) then - print *, 'ERROR: obs_getnobs(): file "observations.uf" does not exist' - end if - stop - end if - inquire(iolength = rsize) record - open(10, file = 'observations.uf', form = 'unformatted',& - access = 'direct', recl = rsize, status = 'old') - - ! I guess there is no other way to work out the length other than read the - ! file in fortran - PS - ! - o = 1 - do while (.true.) - read(10, rec = o, iostat = ios) record - if (ios /= 0) then - nobs = o - 1 - exit - end if - o = o + 1 - enddo - - allocate(obs(nobs)) - - ! PS - there were problem with using rewind(): g95 reported: - ! "Cannot REWIND a file opened for DIRECT access". Therefore reopen. - ! - close(10) - open(10, file = 'observations.uf', form = 'unformatted',& - access = 'direct', recl = rsize, status = 'old') - do o = 1, nobs - read(10, rec = o) obs(o) - call ucase(obs(o) % id) - enddo - close(10) - - if (RFACTOR1 /= 1.0d0) then - do o = 1, nobs - obs(o) % var = obs(o) % var * RFACTOR1 - end do - end if - - call uobs_get(obs % id, nobs, master) - call obs_testrange - end subroutine obs_readobs - - - subroutine obs_testrange - integer :: o, uo, nbad - real :: dmin, dmax - - if (master) then - print '(a)', ' EnKF: testing range for each type of obs ' - end if - do uo = 1, nuobs - if (trim(unique_obs(uo)) == 'SST' .or. trim(unique_obs(uo)) == 'TEM'& - .or. trim(unique_obs(uo)) == 'GTEM') then -#ifdef ANOMALY - dmin = -6.0d0 - dmax = 6.0d0 -#else - dmin = TEM_MIN - dmax = TEM_MAX -#endif - elseif (trim(unique_obs(uo)) == 'SAL'& - .or. trim(unique_obs(uo)) == 'GSAL') then -#ifdef ANOMALY - dmin = -3.0d0 - dmax = 3.0d0 -#else - dmin = SAL_MIN - dmax = SAL_MAX -#endif - elseif (trim(unique_obs(uo)) == 'SLA'& - .or. trim(unique_obs(uo)) == 'TSLA'& - .or. trim(unique_obs(uo)) == 'SSH') then - dmin = SSH_MIN - dmax = SSH_MAX - elseif (trim(unique_obs(uo)) == 'ICEC') then - dmin = ICEC_MIN - dmax = ICEC_MAX - elseif (trim(unique_obs(uo)) == 'VICE'& - .or. trim(unique_obs(uo)) == 'UICE') then - dmin = UVICE_MIN - dmax = UVICE_MAX - else - dmin = -1.0d6 - dmax = 1.0d6 - print *, 'ERROR: obs_testrange(): "', trim(unique_obs(uo)), '": unknown type' - stop - end if - - nbad = 0 - do o = uobs_begin(uo), uobs_end(uo) - if (obs(o) % status .and.& - (obs(o) % d < dmin .or. obs(o) % d > dmax)) then - obs(o) % status = .false. - nbad = nbad + 1 - end if - end do - if (master) then - print '(a, a, a, i6, a)', ' ', trim(unique_obs(uo)), ': ', nbad, ' outliers' - end if - end do - - if (master) then - print * - end if - end subroutine obs_testrange - - - ! Prepare observations before allocating matrices S, D, and A in EnKF(). - ! This invloves mainly thinning, superobing, or sorting. - ! - ! Note that generically this processing can not be completely outsourced - ! to the preprocessing stage, at least for in-situ data, because its thinning - ! involves reading ensemble members for layer depth information. - ! - subroutine obs_prepareobs() - implicit none - - integer :: iuobs - - if (master) then - print '(a)', ' EnKF: preparing observations' - end if - do iuobs = 1, nuobs - call obs_prepareuobs(trim(unique_obs(iuobs))) - end do - - ! calculate again the number of observation of each type (that could change - ! in prepare_obs) - call uobs_get(obs % id, nobs, master) - end subroutine obs_prepareobs - - - ! Prepare (thin, superob) observations of type "obstag". - ! - subroutine obs_prepareuobs(obstag) - character(*), intent(in) :: obstag - - character(STRLEN) :: fname - - if (trim(obstag) == 'SAL' .or. trim(obstag) == 'TEM' .or.& - trim(obstag) == 'GSAL' .or. trim(obstag) == 'GTEM') then - call insitu_prepareobs(trim(obstag), nobs, obs) - if (master) then - write(fname, '(a, ".nc")') trim(obstag) - print *, 'Writing "', trim(obstag), '" obs to be assimilated to "',& - trim(fname), '"' - call insitu_writeprofiles(fname, trim(obstag), nobs, obs); - end if - else - ! do nothing for obs of other types for now - end if - call obs_realloc - end subroutine obs_prepareuobs - - - subroutine obs_realloc() - type(measurement), allocatable :: newobs(:) - - if (nobs < 0 .or. nobs == size(obs)) then - return - end if - - allocate(newobs(nobs)) - newobs = obs(1 : nobs) - deallocate(obs) - allocate(obs(nobs)) - obs = newobs - deallocate(newobs) - end subroutine obs_realloc - - - subroutine obs_QC(m, S) - use m_parameters - implicit none - - integer :: m - real :: S(nobs, m) - - integer :: nmodified(nuobs) - real :: so(m), smean, svar - integer :: o, uo - real :: ovar, inn, newovar - - if (master) then - print *, 'Starting generic observation QC' - end if - - nmodified = 0 - - do uo = 1, nuobs - do o = uobs_begin(uo), uobs_end(uo) - so = S(o, :); - smean = sum(so) / m ! must be 0... - svar = sum((so - smean) ** 2) / real(m - 1) - ovar = obs(o) % var - - inn = obs(o) % d - smean - obs(o) % var = sqrt((svar + ovar) ** 2 +& - svar * (inn / KFACTOR) ** 2) - svar - - if (svar > 0 .and. obs(o) % var / ovar > 2.0d0) then - nmodified(uo) = nmodified(uo) + 1 - end if - end do - end do - - if (master) then - do uo = 1, nuobs - print *, ' ', trim(unique_obs(uo)), ':' - print *, ' # of observations:', uobs_end(uo) - uobs_begin(uo) + 1 - print *, ' (of them) substantially modified:', nmodified(uo) - end do - end if - end subroutine obs_QC - -end module m_obs diff --git a/assim/enkf_cf-system2_old/EnKF/m_oldtonew.F90 b/assim/enkf_cf-system2_old/EnKF/m_oldtonew.F90 deleted file mode 100755 index dea5cfd9..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_oldtonew.F90 +++ /dev/null @@ -1,48 +0,0 @@ -module m_oldtonew - use m_confmap - implicit none - -contains - - ! this routine performes a conformal mapping of the old to the new - ! coordinate system - ! - subroutine oldtonew(lat_o, lon_o, lat_n, lon_n) - real(8), intent(in) :: lat_o, lon_o - real(8), intent(out) :: lat_n, lon_n - - real :: theta, phi, psi, mu - complex :: z, w - - if (.not. confmap_initialised) then - print *, 'ERROR: oldtonew(): confmap not initialised' - stop - end if - - ! transform to spherical coordinates - ! - theta = mod(lon_o * rad + 3.0 * pi_1, 2.0 * pi_1) - pi_1 - phi = pi_2 - lat_o * rad - - ! transform to the new coordinate system - ! - if (abs(phi - pi_1) < epsil) then - mu = mu_s - psi = psi_s - elseif (abs(phi - phi_b) < epsil .and. abs(theta - theta_b) < epsil) then - mu = 0.0 - psi = pi_1 - else - z = tan(0.5 * phi) * exp(imagone * theta) - w = (z - ac) * cmnb / ((z - bc) * cmna) - mu = atan2(aimag(w), real(w)) - psi = 2.0 * atan(abs(w)) - endif - - ! transform to lat/lon coordinates - ! - lat_n = (pi_2 - psi) * deg - lon_n = mu * deg - end subroutine oldtonew - -end module m_oldtonew diff --git a/assim/enkf_cf-system2_old/EnKF/m_parameters.F90 b/assim/enkf_cf-system2_old/EnKF/m_parameters.F90 deleted file mode 100755 index 460b6a98..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_parameters.F90 +++ /dev/null @@ -1,268 +0,0 @@ -! File: m_parameters.F90 -! -! Created: 6 August 2010 -! -! Last modified: 6/8/2010 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Provide a simpl nml list-based parameter input into EnKF. -! -! Description: Provides code for reading parameters from a specified -! parameter file. -! -! Modifications: none - -module m_parameters -#if defined(QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - - integer, parameter, private :: STRLEN = 512 - integer, parameter, private :: FID = 101 - - character(STRLEN), public :: PRMFNAME = "NONE" - - integer, public :: ENSSIZE = 0 - namelist /ensemble/ ENSSIZE - - character(STRLEN), public :: METHODTAG = "NONE" - namelist /method/ METHODTAG - - real, public :: LOCRAD = 0.0d0 - character(STRLEN), public :: LOCFUNTAG = "GASPARI-COHN" - namelist /localisation/ LOCRAD, LOCFUNTAG - - real, public :: INFL = 1.0d0 - real, public :: RFACTOR1 = 1.0d0 - real, public :: RFACTOR2 = 1.0d0 - real, public :: KFACTOR = 2.0d0 - namelist /moderation/ INFL, RFACTOR1, RFACTOR2, KFACTOR - - character(STRLEN), public :: JMAPFNAME = "NONE" - character(STRLEN), public :: POINTFNAME = "NONE" - character(STRLEN), public :: MEANSSHFNAME = "NONE" - namelist /files/ JMAPFNAME, POINTFNAME, MEANSSHFNAME - - integer, parameter, private :: NPRMESTMAX = 10 - integer :: nprmest = 0 - character(STRLEN), dimension(NPRMESTMAX), public :: PRMESTNAME - real, dimension(NPRMESTMAX), public :: PRMINFL - namelist /prmest/ PRMESTNAME, PRMINFL - - public prm_read, prm_describe, prm_print, prm_getinfl, prm_prmestexists, ucase - -contains - - subroutine prm_read - integer :: ios, i - - call getarg(1, PRMFNAME) - - if (master) then - print *, 'EnKF: reading parameters from "', trim(PRMFNAME), '":' - end if - - open(unit = FID, file = trim(PRMFNAME), form = "formatted",& - status = "old", iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: could not open "', trim(PRMFNAME), '", iostatus =', ios - stop - end if - end if - - read(unit = FID, nml = method, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "method"' - end if - stop - end if - rewind(FID) - - read(unit = FID, nml = ensemble, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "ensemble"' - end if - stop - end if - rewind(FID) - - read(unit = FID, nml = localisation, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "localisation"' - end if - stop - end if - rewind(FID) - - read(unit = FID, nml = moderation, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "moderation"' - end if - stop - end if - rewind(FID) - - read(unit = FID, nml = files, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "files"' - end if - stop - end if - rewind(FID) - - do i = 1, NPRMESTMAX - PRMESTNAME(i) = "" - end do - read(unit = FID, nml = prmest, iostat = ios) - if (ios /= 0) then - if (master) then - print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "prmest"' - end if - stop - end if - do i = 1, NPRMESTMAX - if (PRMESTNAME(i) == "") then - nprmest = i - 1 - exit - end if - end do - rewind(FID) - - close(FID) - - call ucase(METHODTAG) - call ucase(LOCFUNTAG) - end subroutine prm_read - - - subroutine prm_describe - if (.not. master) then - return - end if - - print '(a)', ' Example of EnKF parameter file:' - print * - print '(a)', '&method' - print '(a)', ' methodtag = "DEnKF"' - print '(a)', '/' - print '(a)', '&ensemble' - print '(a)', ' enssize = 0' - print '(a)', '/' - print '(a)', '&localisation' - print '(a)', ' locfuntag = "Gaspari-Cohn"' - print '(a)', ' locrad = 300.0' - print '(a)', '/' - print '(a)', '&moderation' - print '(a)', ' infl = 1.01 ()' - print '(a)', ' rfactor1 = 1.0 ()' - print '(a)', ' rfactor2 = 2.0 ()' - print '(a)', ' kfactor = 2.0 ()' - print '(a)', '/' - print '(a)', '&files' - print '(a)', ' jmapfname = "jmap.txt" ()' - print '(a)', ' pointfname = "point2nc.txt" ()' - print '(a)', ' meansshfname = "meanssh.uf" ()' - print * - print '(a)', 'Parameter options:' - print '(a)', ' method = "EnKF" | "DEnKF"*' - print '(a)', ' enssize = (0* to use all available states)' - print '(a)', ' locfuntag = "Gaspari-Cohn"* | "Step" | "None"' - print '(a)', ' locrad = ' - print '(a)', ' infl = (* 1.0)' - print '(a)', ' rfactor1 = (* 1.0)' - print '(a)', ' rfactor2 = (* 1.0)' - print '(a)', ' kfactor = (* 2.0)' - print '(a)', ' jmapfname* = (* none)' - print '(a)', ' pointfname* = (* none)' - print '(a)', ' meansshfname* = (* none)' - end subroutine prm_describe - - - subroutine prm_print - integer :: i - - if (.not. master) then - return - end if - - print '(a)', ' EnKF parameters:' - print '(a)', ' method:' - print '(a, a, a)', ' methodtag = "', trim(METHODTAG), '"' - print '(a)', ' ensemble:' - print '(a, i0)', ' enssize = ', ENSSIZE - print '(a)', ' localisation:' - print '(a, f5.0)', ' locrad = ', LOCRAD - print '(a, a, a)', ' locfuntag = "', trim(LOCFUNTAG), '"' - print '(a)', ' moderation:' - print '(a, f5.3)', ' infl = ', INFL - print '(a, f3.1)', ' rfactor1 = ', RFACTOR1 - print '(a, f3.1)', ' rfactor2 = ', RFACTOR2 - print '(a, f3.1)', ' kfactor = ', KFACTOR - print '(a)', ' files:' - print '(a, a, a)', ' jmapfname = "', trim(JMAPFNAME), '"' - print '(a, a, a)', ' pointfname = "', trim(POINTFNAME), '"' - print '(a, a, a)', ' meansshfname = "', trim(MEANSSHFNAME), '"' - print '(a, i0, a)', ' prmest: ', nprmest, ' fields' - do i = 1, nprmest - print '(a, a, a, f5.3)', ' prmestname = "', trim(PRMESTNAME(i)), '", infl = ', PRMINFL(i) - end do - print * - end subroutine prm_print - - - function prm_getinfl(fldname) - real :: prm_getinfl - character(*), intent(in) :: fldname - integer :: i - - prm_getinfl = INFL - do i = 1, nprmest - if (trim(fldname) == PRMESTNAME(i)) then - prm_getinfl = PRMINFL(i) - print '(a, a, a, f5.3)', ' "', trim(fldname), '": using inflation = ', prm_getinfl - return - end if - end do - end function prm_getinfl - - - function prm_prmestexists(varname) - logical :: prm_prmestexists - character(*), intent(in) :: varname - integer :: i - - prm_prmestexists = .false. - do i = 1, nprmest - if (trim(varname) == PRMESTNAME(i)) then - prm_prmestexists = .true. - return - end if - end do - end function prm_prmestexists - - - ! Shift a character string to upper case. - ! - subroutine ucase(string) - character(*) :: string - integer :: i - - do i = 1, len(string) - if (string(i:i) >= 'a' .and. string(i:i) <= 'z') then - string(i:i) = achar (iachar ( string(i:i) ) - 32) - end if - end do - end subroutine ucase - -end module m_parameters diff --git a/assim/enkf_cf-system2_old/EnKF/m_parse_blkdat.F90 b/assim/enkf_cf-system2_old/EnKF/m_parse_blkdat.F90 deleted file mode 100755 index ae5dede6..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_parse_blkdat.F90 +++ /dev/null @@ -1,141 +0,0 @@ -module m_parse_blkdat - private :: blkini, blkinr, blkinvoid -contains - - - subroutine parse_blkdat(cvar,vtype,realvar,intvar,blkfilein,imatch) - implicit none - character(len=6), intent(in) :: cvar - character(len=*), intent(in) :: vtype - integer, intent(out) :: intvar - real , intent(out) :: realvar - character(len=*), intent(in), optional :: blkfilein - integer , intent(in), optional :: imatch - - character(len=80) :: blkfile - - logical :: found,ex - integer :: nmatch,imatch2 - - if (present(blkfilein)) then - blkfile=blkfilein - else - blkfile='blkdat.input' - end if - if (present(imatch)) then - imatch2=imatch - else - imatch2=1 - end if - - - - inquire(exist=ex,file=trim(blkfile)) - - nmatch=0 - if (ex) then - open(99,file=trim(blkfile),status='old') - - - ! Skip header - read(99,*) - read(99,*) - read(99,*) - read(99,*) - - found=.false. - - do while (.not.found) - found = blkinvoid(cvar) - - if (found) then - nmatch=nmatch+1 - !print *,found,nmatch,imatch2 - found=found.and.nmatch==imatch2 - !print *,found - end if - - end do - - ! if found, read.. - if (found) then - backspace(99) - if (trim(vtype)=='integer') then - call blkini(intvar,cvar) - elseif (trim(vtype)=='real') then - call blkinr(realvar,cvar,'(a6," =",f10.4," m")') - else - print *,'Dont know how to handle variable type '//trim(vtype) - stop '(parse_blkdat)' - end if - else - print *,'Cant find varable' - stop '(parse_blkdat)' - end if - - close(99) - else - print *,'Cant find '//trim(blkfile) - stop '(parse_blkdat)' - end if - end subroutine parse_blkdat - - - - - subroutine blkinr(rvar,cvar,cfmt) - !use mod_xc ! HYCOM communication interface - implicit none - real rvar - character cvar*6,cfmt*(*) -! read in one real value - character*6 cvarin - - read(99,*) rvar,cvarin - write(6,cfmt) cvarin,rvar - !call flush(6) - - if (cvar.ne.cvarin) then - write(6,*) - write(6,*) 'error in blkinr - input ',cvarin, & - ' but should be ',cvar - write(6,*) - !call flush(6) - stop '(blkinr)' - endif - return - end subroutine - - subroutine blkini(ivar,cvar) - implicit none - integer ivar - character*6 cvar -! read in one integer value - character*6 cvarin - - read(99,*) ivar,cvarin - - if (cvar.ne.cvarin) then - write(6,*) - write(6,*) 'error in blkini - input ',cvarin, & - ' but should be ',cvar - write(6,*) - !call flush(6) - stop '(blkini)' - endif - end subroutine blkini - - - - logical function blkinvoid(cvar) - implicit none - - real :: rvar - character :: cvar*6 - character*6 :: cvarin - - read(99,*) rvar, cvarin - blkinvoid = trim(cvar) == trim(cvarin) - end function blkinvoid - -end module m_parse_blkdat diff --git a/assim/enkf_cf-system2_old/EnKF/m_pivotp.F90 b/assim/enkf_cf-system2_old/EnKF/m_pivotp.F90 deleted file mode 100755 index e044d604..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_pivotp.F90 +++ /dev/null @@ -1,51 +0,0 @@ -module m_pivotp - use m_confmap - implicit none - -contains - - ! This subroutine computes the pivot point of each of the observations - ! in the temporary array tmpobs of type observation. The pivot point - ! is the biggest i and the biggest j, (i,j) is the computation points/ - ! the grid, that is less than the position of the observation. - ! - subroutine pivotp(lon, lat, ipiv, jpiv) - real, intent(in) :: lon, lat - integer, intent(out) :: ipiv, jpiv - - real :: tmptan - real :: lontmp - - if (.not. confmap_initialised) then - print *, 'ERROR: oldtonew(): confmap not initialised' - stop - end if - - ! fix for wrap-around - ! Knut: For some exotic grids the wrap-around - ! is not needed. By exotic grid I mean Conman, - ! where the poles are on the other side of the earth, - ! and the eastern limit is actually WEST of the western - ! limit.... (di < 0) - !if (lon < wlim) then - if (lon < wlim .and. di > 0. ) then - lontmp = lon + 360.0 - else - lontmp = lon - endif - - ipiv = int((lontmp - wlim) / di) + 1 - - if (mercator) then - if (abs(lat) < 89.999) then - tmptan = tan(0.5 * rad * lat + 0.25 * pi_1) - jpiv = int((log(tmptan) - slim * rad) / (rad * dj)) + 1 - else - jpiv= - 999 - endif - else - jpiv = int((lat - slim) / dj) + 1 - endif - end subroutine pivotp - -end module m_pivotp diff --git a/assim/enkf_cf-system2_old/EnKF/m_point2nc.F90 b/assim/enkf_cf-system2_old/EnKF/m_point2nc.F90 deleted file mode 100755 index f9c5b115..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_point2nc.F90 +++ /dev/null @@ -1,339 +0,0 @@ -! File: m_point2nc.F90 -! -! Created: 6 July 2010 -! -! Last modified: 6/7/2010 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Output of assimilation related information for selected points -! to files in NetCDF format, 1 file per point. -! -! Description: This module reads a list of points from a file "point2nc.txt" -! in the working NetCDF directory. It then dumps the -! assimilation related information for these points in NetCDF -! format to files named enkf_III,JJJ.nc, where III and JJJ - i -! and j grid coordinates. -! -! Modifications: PS 4/8/2010 "point2nc.txt" now allows comments etc. E.g. put -! "#" in front of an entry to comment it out. - -module m_point2nc - use m_parameters - implicit none - - integer, private :: FID = 31 - integer, parameter, private :: STRLEN = 512 - - public p2nc_init - public p2nc_testthiscell - public p2nc_writeobs - public p2nc_storeforecast - public p2nc_writeforecast - - integer, private :: npoints - integer, allocatable, dimension(:), private :: icoords, jcoords - real(4), allocatable, dimension(:, :, :) :: forecast - -contains - - ! Initialise the point output. - ! - subroutine p2nc_init() -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - - character(STRLEN) :: line - integer :: iostatus - integer :: i, j, n - - npoints = 0 - - open(FID, file = trim(POINTFNAME), status = 'old', iostat = iostatus) - if (iostatus /= 0) then - if (master) then - print *, 'WARNING: could not open "', trim(POINTFNAME), '" for reading' - print *, ' no point output will be performed' - end if - return - end if - - do while (.true.) - read(FID, '(a)', iostat = iostatus) line - if (iostatus == 0) then - read(line, *, iostat = iostatus) i, j - if (iostatus == 0) then - npoints = npoints + 1 - end if - else - exit - end if - end do - close(FID) - - if (master) then - print '(a, i3, a)', ' p2nc: ', npoints, ' points specified' - end if - - allocate(icoords(npoints), jcoords(npoints)) - - open(FID, file = trim(POINTFNAME), status = 'old', iostat = iostatus) - if (iostatus /= 0) then - print *, 'ERROR: point2nc: I/O problem' - stop - end if - - n = 0 - do while (n < npoints) - read(FID, '(a)', iostat = iostatus) line - if (iostatus == 0) then - read(line, *, iostat = iostatus) i, j - if (iostatus == 0) then - n = n + 1 - icoords(n) = i - jcoords(n) = j - if (master) then - print '(a, i3, a, i4, a, i4)', ' point', n, ': i =', i, ', j =', j - end if - end if - end if - end do - close(FID) - if (master) then - print * - end if - end subroutine p2nc_init - - - ! Test if the output is requested for the point (i, j) - ! - function p2nc_testthiscell(i, j) - logical :: p2nc_testthiscell - integer, intent(in) :: i, j - - integer :: p - - p2nc_testthiscell = .false. - do p = 1, npoints - if (i == icoords(p) .and. j == jcoords(p)) then - p2nc_testthiscell = .true. - return - end if - end do - end function p2nc_testthiscell - - - ! Write the assimilation parameters (local observations and the X5 matrices) - ! to the point output files. - ! - subroutine p2nc_writeobs(i, j, nlobs, nens, X5, lon, lat, depth, rfactor,& - ids, lobs, Hx, S, ss, lfactors) - use mod_measurement - use m_obs - use nfw_mod - - integer, intent(in) :: i, j, nlobs, nens - real, intent(in) :: X5(nens, nens) - real, intent(in) :: lon(1), lat(1), depth(1) - real, intent(in), optional :: rfactor(1) - integer, intent(in), optional :: ids(nlobs) - type(measurement), intent(in), optional :: lobs(nlobs) - real, intent(in), optional :: Hx(nlobs) - real, intent(in), optional :: S(nlobs, nens) - real, intent(in), optional :: ss(nlobs), lfactors(nlobs) - - character(STRLEN) :: fname - character(STRLEN) :: typename - integer :: ncid - integer :: dids(2) - integer :: vid_ids, vid_lon, vid_lat, vid_val, vid_var, vid_hx, vid_s, vid_x5 - integer :: vid_a1, vid_a2, vid_a3, vid_a4, vid_otype, vid_ss, vid_lfactors - integer :: otype(nlobs) - integer :: o, ot - - write(fname, '(a, i0.3, ",", i0.3, ".nc")') 'enkf_', i, j - call nfw_create(fname, nf_write, ncid) - - call nfw_def_dim(fname, ncid, 'p', nlobs, dids(2)) - call nfw_def_dim(fname, ncid, 'm', nens, dids(1)) - if (nlobs > 0) then - call nfw_def_var(fname, ncid, 'obs_ids', nf_int, 1, dids(2), vid_ids) - call nfw_def_var(fname, ncid, 'Hx', nf_double, 1, dids(2), vid_hx) - call nfw_def_var(fname, ncid, 'lon', nf_double, 1, dids(2), vid_lon) - call nfw_def_var(fname, ncid, 'lat', nf_double, 1, dids(2), vid_lat) - call nfw_def_var(fname, ncid, 'obs_val', nf_double, 1, dids(2), vid_val) - call nfw_def_var(fname, ncid, 'obs_var', nf_double, 1, dids(2), vid_var) - call nfw_def_var(fname, ncid, 'a1', nf_double, 1, dids(2), vid_a1) - call nfw_def_var(fname, ncid, 'a2', nf_double, 1, dids(2), vid_a2) - call nfw_def_var(fname, ncid, 'a3', nf_double, 1, dids(2), vid_a3) - call nfw_def_var(fname, ncid, 'a4', nf_double, 1, dids(2), vid_a4) - call nfw_def_var(fname, ncid, 'obs_type', nf_int, 1, dids(2), vid_otype) - call nfw_def_var(fname, ncid, 'S', nf_double, 2, dids, vid_s) - call nfw_def_var(fname, ncid, 's', nf_double, 1, dids(2), vid_ss) - call nfw_def_var(fname, ncid, 'lfactors', nf_double, 1, dids(2), vid_lfactors) - end if - dids(2) = dids(1) - call nfw_def_var(fname, ncid, 'X5', nf_double, 2, dids, vid_x5) - - call nfw_put_att_double(fname, ncid, nf_global, 'lon', nf_double, 1, lon) - call nfw_put_att_double(fname, ncid, nf_global, 'lat', nf_double, 1, lat) - call nfw_put_att_double(fname, ncid, nf_global, 'depth', nf_double, 1, depth) - !call nfw_put_att_double(fname, ncid, nf_global, 'rfactor', nf_double, 1, rfactor) - - do ot = 1, nuobs - write(typename, '(a, i1)') 'obstype', ot - call nfw_put_att_text(fname, ncid, nf_global, typename, len_trim(unique_obs(ot)), trim(unique_obs(ot))) - end do - - call nfw_enddef(fname, ncid) - - if (nlobs > 0) then - call nfw_put_var_double(fname, ncid, vid_hx, Hx) - call nfw_put_var_int(fname, ncid, vid_ids, ids) - call nfw_put_var_double(fname, ncid, vid_lon, lobs % lon) - call nfw_put_var_double(fname, ncid, vid_lat, lobs % lat) - call nfw_put_var_double(fname, ncid, vid_val, lobs % d) - call nfw_put_var_double(fname, ncid, vid_var, lobs % var) - call nfw_put_var_double(fname, ncid, vid_a1, lobs % a1) - call nfw_put_var_double(fname, ncid, vid_a2, lobs % a2) - call nfw_put_var_double(fname, ncid, vid_a3, lobs % a3) - call nfw_put_var_double(fname, ncid, vid_a4, lobs % a4) - otype = 0 - do o = 1, nlobs - do ot = 1, nuobs - if (trim(lobs(o) % id) == trim(unique_obs(ot))) then - otype(o) = ot - end if - end do - end do - - call nfw_put_var_int(fname, ncid, vid_otype, otype) - call nfw_put_var_double(fname, ncid, vid_s, transpose(S)) - call nfw_put_var_double(fname, ncid, vid_ss, ss) - call nfw_put_var_double(fname, ncid, vid_lfactors, lfactors) - end if - - call nfw_put_var_double(fname, ncid, vid_x5, transpose(X5)) - - call nfw_close(fname, ncid) - end subroutine p2nc_writeobs - - - ! Store the values of the forecast field No. `fid' in each output point to - ! the variable `forecast'. - ! - subroutine p2nc_storeforecast(ni, nj, nrens, nfields, fid, field) - integer, intent(in) :: ni, nj ! size of grid - integer, intent(in) :: nrens - integer, intent(in) :: nfields - integer, intent(in) :: fid - real(4), dimension(ni * nj, nrens), intent(in) :: field - - integer :: n - - if (npoints == 0) then - return - end if - - if (.not. allocated(forecast)) then - allocate(forecast(nrens, npoints, nfields)) - end if - - do n = 1, npoints - forecast(:, n, fid) = field((jcoords(n) - 1) * ni + icoords(n), :) - end do - end subroutine p2nc_storeforecast - - - ! This procedure consolidates all forecast fields for each output point - ! together in the variable `forecast' on the master node, and then writes - ! them to the appropriate NetCDF files. - ! - subroutine p2nc_writeforecast -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use distribute - use nfw_mod - use mod_analysisfields - implicit none - - character(STRLEN) :: fname - integer :: p, k, nf - character(8) :: varname - integer kstart - integer ncid, dids(2), varid, nf2 - -#if defined(QMPI) - if (.not. master) then - call send(forecast(:, :, my_first_iteration : my_last_iteration), 0, 0) - return ! leave writing to master - else - do p = 2, qmpi_num_proc ! here p is the MPI node ID - call receive(forecast(:, :, first_iteration(p) : last_iteration(p)), p - 1, 0) - end do - end if -#endif - - ! only master keeps working here - ! - do p = 1, npoints - write(fname, '(a, i0.3, ",", i0.3, ".nc")') 'enkf_', icoords(p), jcoords(p) - call nfw_open(fname, nf_write, ncid) - call nfw_redef(fname, ncid) - call nfw_inq_dimid(fname, ncid, 'm', dids(1)) - call nfw_enddef(fname, ncid) - - kstart = -1 - do k = 1, numfields - if (kstart == -1) then - kstart = k - varname = fieldnames(k) - end if - - ! check if there are more fields for this variable - ! - if (k < numfields .and. fieldnames(k + 1) == varname) then - cycle - end if - - ! this is the last field for this variable - write the variable - ! - nf = k - kstart + 1 - - call nfw_redef(fname, ncid) - - if (nf == 1) then - call nfw_def_var(fname, ncid, trim(varname), nf_float, 1, dids(1), varid) - else - if (.not. nfw_dim_exists(ncid, 'k')) then - call nfw_def_dim(fname, ncid, 'k', nf, dids(2)) - else - call nfw_inq_dimid(fname, ncid, 'k', dids(2)) - call nfw_inq_dimlen(fname, ncid, dids(2), nf2) - if (nf /= nf2) then - print *, 'ERROR: p2nc_writeforecast(): varname = "', trim(varname),& - '", # levels = ', nf, '# levels in "', trim(fname), '" =', nf2 - print *, 'ERROR: p2nc_writeforecast(): returning' - end if - end if - call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dids, varid) - end if - - call nfw_enddef(fname, ncid) - - call nfw_put_var_real(fname, ncid, varid, forecast(:, p, kstart : kstart + nf - 1)) - - kstart = -1 - end do - call nfw_close(fname, ncid) - end do - end subroutine p2nc_writeforecast - -end module m_point2nc diff --git a/assim/enkf_cf-system2_old/EnKF/m_prep_4_EnKF.F90 b/assim/enkf_cf-system2_old/EnKF/m_prep_4_EnKF.F90 deleted file mode 100755 index 5568338a..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_prep_4_EnKF.F90 +++ /dev/null @@ -1,473 +0,0 @@ -! File: m_prep_4_EnKF.F90 -! -! Created: ??? -! -! Last modified: 29/06/2010 -! -! Purpose: Calculation of HA ("S") -! -! Description: Calculates HA by going sequentially through each data type. -! -! Modifications: -! 07/08/2017 MK: added projection Hx for multicategory ice -! 05/08/2016 Yiguo WANG: add SSH data type -! 22/07/2016 Yiguo WANG: add ANOMALY option for profile data -! 09/03/2016 Yiguo WANG: replace get_S() by get_S_spline() -! 29/07/2010 PS: -! - merged insitu_QC() with generic obs_QC(). Moved -! insitu_writeforecast() to the point after QC. -! 29/06/2010 PS: -! - added generic observation QC: increase the observation -! error when observation and ensemble mean are much too far -! away than expected -! Prior history: -! Not documented. - -module m_prep_4_EnKF - - integer, parameter, private :: STRLEN = 512 - - private read_mean_ssh - -contains - - ! This subroutine uses the observation and ensembles from the model - ! to prepare the input to the EnKF analysis scheme. - ! The output from this routine is used directly in the global analysis - ! while the output has to be run through a "filter" to be used in the - ! local analysis scheme. - - ! S = HA (ensemble observation anomalies) - ! d = d - Hx (innovations) - ! - ! S is calculated in two steps: - ! 1. S = HE - ! 2. S = S - repmat(s, 1, m), - ! where s = mean(S')'; - ! Note that in reality (with HYCOM/MICOM) H is different for each member... - ! So that HX must be read "HX" rather than "H * X". - ! - subroutine prep_4_EnKF(nrens, d, S, depths, meandx, nx, ny, nz, ncat) -#if defined (QMPI) - use qmpi, only : master, stop_mpi -#else - use qmpi_fake, only : master, stop_mpi -#endif - use mod_measurement - use m_obs - use m_Generate_element_Si - use m_get_micom_fld - use m_parameters - implicit none - - integer, intent(in) :: nx, ny, nz ! Model size - integer, intent(in) :: nrens ! Size of ensemble - real, intent(in) :: depths(nx, ny) - real, intent(in) :: meandx ! mean grid size - integer, intent(in), optional :: ncat - real, intent(inout) :: d(nobs) - real, intent(inout) :: S(nobs, nrens) - - real :: x(nobs) - - integer :: i, j, m, iens - real*4, dimension(nx,ny) :: fldr4 - real :: readfld(nx, ny) - real :: C(nobs) - - ! hard-coded for now - integer, parameter :: drnx = 152, drny = 132 - real*4, dimension(drnx, drny) :: modzon, modmer - - integer :: reclSLA, ios, reclDRIFT - character*3 :: cmem - character*2 :: day - - logical :: ex - - character(STRLEN) :: fname - integer :: iuobs - - ! FANF: For track assim we launch m_Generate_Si for each day (t=1:Wd) - ! which fills in S at the appropriate indices. - ! Wd is the assimilation cycle (i.e. 7 days) - ! - integer :: Wd, t - integer :: tlevel - real :: field2(nx, ny), field3(nx, ny) ! auxiliary fields (e.g. mean SSH, - ! field bias estimate etc.) - integer :: nthisobs, thisobs(nobs) - - if (any(obs(:) % id == 'TSLA ')) then - Wd = 6 - else - Wd = 0 - endif - - ! security check - ! - if (any(obs(:) % id == 'SSH ') .or. any(obs(:) % id == 'SLA ')) then - if (any(obs(:) % id == 'SLA ')) then - inquire(exist = ex, file = 'model_SLA.uf') - if (.not.ex) then - if (master) print *,'model_SLA.uf does not exist' - call stop_mpi() - end if - end if - if (any(obs(:) % id == 'SSH ')) then - inquire(exist = ex, file = 'model_SSH.uf') - if (.not.ex) then - if (master) print *,'model_SSH.uf does not exist' -! call stop_mpi() - end if - end if - end if - - ! construct S=HA - ! - do iuobs = 1, nuobs - - if (master) then - print *, 'prep_4_EnKF: now preparing "', trim(unique_obs(iuobs)), '" observations' - end if - - if (trim(unique_obs(iuobs)) == 'ICEC') then - do iens = 1, nrens - write(cmem,'(i3.3)') iens - readfld(:,:)=0. - do m = 1, ncat -! print *,'We are reading category',m,trim('forecast_ice'//cmem) - ! BIPOL/TRIPOL - dependent in the routine - call get_micom_fld_ice(trim('forecast_ice'//cmem), field2,'aicen', m, m, nx, ny) - readfld=readfld+field2 - end do - -#ifdef ANOMALY -!Read the monthly mean - call get_micom_fld_new('mean_mod', field2, 'ficem', 0, 1, nx, ny) - readfld = readfld - field2 -#endif - call Generate_element_Si(S(:, iens), unique_obs(iuobs),& - readfld, depths, nx, ny, nz, 0) - end do - - elseif (trim(unique_obs(iuobs)) == 'SST') then - do iens = 1, nrens - write(cmem,'(i3.3)') iens - call get_micom_fld_new(trim('forecast'//cmem), readfld, & - 'temp', 1, 1, nx, ny) -#ifdef ANOMALY -!Read the monthly mean - call get_micom_fld_new('mean_mod', field2, & - 'sst', 0, 1, nx, ny) - readfld = readfld - field2 -#endif - call Generate_element_Si(S(:, iens), unique_obs(iuobs),& - readfld, depths, nx, ny, nz, 0) - end do - - elseif (trim(unique_obs(iuobs)) == 'SSH') then - do iens = 1, nrens - write(cmem,'(i3.3)') iens - call get_micom_fld_new(trim('forecast'//cmem), readfld, & - 'sealv', 1, 1, nx, ny) - ! Convert to meter - readfld = readfld/100. - - !Read the monthly mean - call get_micom_fld_new('mean_mod', field2, & - 'sealv', 0, 1, nx, ny) - readfld = readfld - field2 - - call Generate_element_Si(S(:, iens), unique_obs(iuobs),& - readfld, depths, nx, ny, nz, 0) - end do - - elseif (trim(unique_obs(iuobs)) == 'SLA' .or.& - trim(unique_obs(iuobs)) == 'TSLA') then - - if (trim(unique_obs(iuobs)) == 'TSLA') then - call read_mean_ssh(field2, nx, ny) - end if - - do iens = 1, nrens - write(cmem,'(i3.3)') iens - call get_micom_fld_new(trim('forecast'//cmem), readfld, & - 'ssh', 1, 1, nx, ny) - if (prm_prmestexists('msshb')) then - write(cmem,'(i3.3)') iens - call get_micom_fld_new(trim('forecast'//cmem), field3,& - 'msshb', 0, 1, nx, ny) - readfld = readfld - field3 ! mean SSH bias for this member - end if - if (trim(unique_obs(iuobs)) == 'TSLA') then - readfld = readfld - field2 ! mean SSH - end if - - call Generate_element_Si(S(:, iens), unique_obs(iuobs),& - readfld, depths, nx, ny, nz, t) - end do - if (master) then - print *, 'forming S, day', t - print *, ' # of non-zero ens observations = ', count(S /= 0.0) - print *, ' # of zero ens observations = ', count(S == 0.0) - print *, ' # of non-zero observations for member 1 = ', count(S(:, 1) /= 0.0) - end if - - elseif (trim(unique_obs(iuobs)) == 'SAL' .or.& - trim(unique_obs(iuobs)) == 'TEM' .or.& - trim(unique_obs(iuobs)) == 'GSAL' .or.& - trim(unique_obs(iuobs)) == 'GTEM') then - - if (master) then - print *, ' Interpolating ensemble vectors to the locations of "',& - trim(unique_obs(iuobs)), '" observations' - end if - -#ifdef ANOMALY - !Read the monthly mean - call get_climato_spline(C, trim(unique_obs(iuobs)), nobs, obs) -#endif - ! - ! for each ensemble member process all profiles "in parallel", - ! reading the fields layer by layer - ! - do iens = 1, nrens - call get_S_spline(S(:, iens), trim(unique_obs(iuobs)), nobs, obs, iens) -#ifdef ANOMALY - S(uobs_begin(iuobs) : uobs_end(iuobs), iens) = S(uobs_begin(iuobs) : uobs_end(iuobs), iens) & - - C(uobs_begin(iuobs) : uobs_end(iuobs)) -#endif - end do - if (master) then - print *, ' Interpolation completed' - end if - - else - if (master) then - print *,'ERROR: unknown obs type ' // trim(unique_obs(iuobs)) - end if - call stop_mpi() - end if - end do ! iuobs - - ! some generic QC - relax fitting if the model and obs are too far apart - ! - call obs_QC(nrens, S) - - ! add calculated HA to to observations-.nc files for each data type - ! - do iuobs = 1, nuobs - if (master) then - nthisobs = 0 - do m = 1, nobs - if (trim(unique_obs(iuobs)) == trim(obs(m) % id)) then - nthisobs = nthisobs + 1 - thisobs(nthisobs) = m - end if - end do - - ! add forecast values to the observation-.nc files - ! - call add_forecast(unique_obs(iuobs), S(thisobs(1 : nthisobs), :), obs(thisobs(1 : nthisobs))) - - ! append the superobed values (and modified observation error - ! variances) to the file with pre-processed observations (SAL.nc, - ! TEM.nc, GSAL.nc or GTEM.nc) - ! - if (trim(unique_obs(iuobs)) == 'SAL' .or.& - trim(unique_obs(iuobs)) == 'TEM' .or.& - trim(unique_obs(iuobs)) == 'GSAL' .or.& - trim(unique_obs(iuobs)) == 'GTEM') then - - call insitu_writeforecast(unique_obs(iuobs), nobs, nrens, S, obs) - end if - end if - end do - - if (master) then - print *, 'm_prep_4_EnKF: end calculating S = HA' - end if - - x = sum(S, DIM = 2) / real(nrens) - if (master) print*,'m_prep_4_EnKF: end calculating Hx' - if (master) then - print *, 'Hx range = ', minval(x), '-', maxval(x) - print *, 'mean(Hx) = ', sum(x) / real(nobs) - end if - if (master) then - print *, 'observation range = ', minval(obs % d), '-', maxval(obs % d) - print *, 'mean(observation) = ', sum(obs % d) / nobs - end if - ! Compute HA = HE - mean(HE) - ! - if (master) print*,'prep_4_EnKF(): calculating S = S - x' - do j = 1, nrens - S(:, j) = S(:, j) - x - enddo - ! Compute innovation - ! - d = obs % d - x - if (master) then - print *, ' innovation range = ', minval(d), '-', maxval(d) - if (minval(d) < -1000.0d0) then - print *, 'm_prep_4_EnKF: error: innovation too small detected' - call stop_mpi() - end if - if (maxval(d) > 1000.0d0) then - print *, 'm_prep_4_EnKF: error: innovation too big detected' - call stop_mpi() - end if - end if - - end subroutine prep_4_EnKF - - - subroutine read_mean_ssh(mean_ssh, nx, ny) -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use m_parameters - - integer, intent(in) :: nx, ny - real, intent(out):: mean_ssh(nx, ny) - logical :: exists - - inquire(file = trim(MEANSSHFNAME), exist = exists) - if (.not. exists) then - if (master) then - print *,'ERROR: read_mean_ssh(): file "', trim(MEANSSHFNAME), '" not found' - end if - stop - end if - - open (10, file = trim(MEANSSHFNAME), status = 'unknown',form = 'unformatted') - read (10) mean_ssh - close (10) - end subroutine read_mean_ssh - - - ! This subroutine adds forecast observations (i.e Hx) to the NetCDF - ! observation files for each data type. - ! - subroutine add_forecast(obstag, S, obs) - use mod_measurement - use nfw_mod - implicit none - - character(OBSTYPESTRLEN), intent(in) :: obstag - real, dimension(:, :), intent(in) :: S - type(measurement), dimension(:) :: obs - - character(STRLEN) :: fname - logical :: exists - integer :: ncid - integer :: dids(2), dimlen - logical :: addsobs - integer :: for_id, inn_id, forvar_id, slon_id, slat_id,& - sdepth_id, sipiv_id, sjpiv_id, sd_id, svar_id,& - newvar_id - - real, allocatable, dimension(:) :: x, Svar, innovation - - integer :: m, p, o - - write(fname, '(a, a, a)') 'observations-', trim(obstag), '.nc' - inquire(file = trim(fname), exist = exists) - if (.not. exists) then - print *, 'file "', trim(fname), 'not found, skip adding forecast' - return - else - print *, 'dumping forecast to "', trim(fname), '"' - end if - - p = size(S, DIM = 1) - m = size(S, DIM = 2) - - allocate(x(p), Svar(p), innovation(p)) - - x = sum(S, DIM = 2) / real(m); - Svar = 0.0 - do o = 1, p - Svar(o) = sum((S(o, :) - x(o))** 2) - end do - Svar = Svar / real(m - 1) - innovation = obs % d - x - - addsobs = .false. - call nfw_open(fname, nf_write, ncid) - call nfw_inq_dimid(fname, ncid, 'nobs', dids(1)) - call nfw_inq_dimlen(fname, ncid, dids(1), dimlen) - - call nfw_redef(fname, ncid) - if (dimlen == p) then - dids(2) = dids(1) - elseif (.not. nfw_dim_exists(ncid, 'nsobs')) then - addsobs = .true. - call nfw_def_dim(fname, ncid, 'nsobs', p, dids(2)) - call nfw_def_var(fname, ncid, 'slon', nf_float, 1, dids(2), slon_id) - call nfw_def_var(fname, ncid, 'slat', nf_float, 1, dids(2), slat_id) - call nfw_def_var(fname, ncid, 'sdepth', nf_float, 1, dids(2), sdepth_id) - call nfw_def_var(fname, ncid, 'sipiv', nf_int, 1, dids(2), sipiv_id) - call nfw_def_var(fname, ncid, 'sjpiv', nf_int, 1, dids(2), sjpiv_id) - call nfw_def_var(fname, ncid, 'sd', nf_float, 1, dids(2), sd_id) - call nfw_def_var(fname, ncid, 'svar', nf_float, 1, dids(2), svar_id) - end if - if (.not. nfw_var_exists(ncid, 'innovation')) then - call nfw_def_var(fname, ncid, 'innovation', nf_double, 1, dids(2), inn_id) - else - call nfw_inq_varid(fname, ncid, 'innovation', inn_id) - end if - if (.not. nfw_var_exists(ncid, 'forecast')) then - call nfw_def_var(fname, ncid, 'forecast', nf_double, 1, dids(2), for_id) - else - call nfw_inq_varid(fname, ncid, 'forecast', for_id) - end if - if (.not. nfw_var_exists(ncid, 'forecast_variance')) then - call nfw_def_var(fname, ncid, 'forecast_variance', nf_double, 1, dids(2), forvar_id) - else - call nfw_inq_varid(fname, ncid, 'forecast_variance', forvar_id) - end if - if (.not. addsobs) then - if (dimlen == p) then - if (.not. nfw_var_exists(ncid, 'new_var')) then - call nfw_def_var(fname, ncid, 'new_var', nf_double, 1, dids(2), newvar_id) - else - call nfw_inq_varid(fname, ncid, 'new_var', newvar_id) - end if - else - if (.not. nfw_var_exists(ncid, 'new_svar')) then - call nfw_inq_dimid(fname, ncid, 'nsobs', dids(2)) - call nfw_def_var(fname, ncid, 'new_svar', nf_double, 1, dids(2), newvar_id) - else - call nfw_inq_varid(fname, ncid, 'new_svar', newvar_id) - end if - end if - end if - call nfw_enddef(fname, ncid) - - call nfw_put_var_double(fname, ncid, forvar_id, Svar) - call nfw_put_var_double(fname, ncid, for_id, x) - call nfw_put_var_double(fname, ncid, inn_id, innovation) - if (addsobs) then - call nfw_put_var_double(fname, ncid, slon_id, obs % lon) - call nfw_put_var_double(fname, ncid, slat_id, obs % lat) - call nfw_put_var_double(fname, ncid, sdepth_id, obs % depth) - call nfw_put_var_int(fname, ncid, sipiv_id, obs % ipiv) - call nfw_put_var_int(fname, ncid, sjpiv_id, obs % jpiv) - call nfw_put_var_double(fname, ncid, sd_id, obs % d) - call nfw_put_var_double(fname, ncid, svar_id, obs % var) - else - call nfw_put_var_double(fname, ncid, newvar_id, obs % var) - end if - - call nfw_close(fname, ncid) - - deallocate(x) - deallocate(Svar) - deallocate(innovation) - end subroutine add_forecast - -end module m_prep_4_EnKF diff --git a/assim/enkf_cf-system2_old/EnKF/m_put_micom_fld.F90 b/assim/enkf_cf-system2_old/EnKF/m_put_micom_fld.F90 deleted file mode 100755 index dbc49219..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_put_micom_fld.F90 +++ /dev/null @@ -1,62 +0,0 @@ -module m_put_micom_fld -use qmpi, only : master -use netcdf -use nfw_mod -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -! KAL - This is for the new file type -subroutine put_micom_fld(memfile,fld,iens,cfld,vlevel,tlevel,nx,ny) - implicit none - integer, intent(in) :: nx,ny - integer, intent(in) :: iens ! Ensemble member to read - real, dimension(nx,ny), intent(in) :: fld ! output fld - character(len=*), intent(in) :: memfile! base name of input files - character(len=8), intent(in) :: cfld ! name of fld - integer, intent(in) :: tlevel ! time level - integer, intent(in) :: vlevel ! vertical level - - integer :: ex, ncid, vFIELD_ID - integer, allocatable :: ns(:), nc(:) - - - if (master .and. iens.eq.1) then - print *,'Dumping ',trim(cfld),vlevel - endif - inquire(file=trim(memfile)//'.nc',exist=ex) - ! Reading the observation file of satellite - call nfw_open(trim(memfile)//'.nc', or(nf_write,nf_share), ncid) - call nfw_inq_varid(trim(memfile)//'.nc', ncid,trim(cfld),vFIELD_ID) - - if (vlevel==0) then - allocate(ns(3)) - allocate(nc(3)) - ns(1)=1 - ns(2)=1 - ns(3)=1 - nc(1)=nx - nc(2)=ny - nc(3)=1 - call nfw_put_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, fld) - else - allocate(ns(4)) - allocate(nc(4)) - ns(1)=1 - ns(2)=1 - ns(3)=vlevel - ns(4)=1 - nc(1)=nx - nc(2)=ny - nc(3)=1 - nc(4)=1 - call nfw_put_vara_double(trim(memfile)//'.nc', ncid, vFIELD_ID, ns, nc, fld) - endif - call nfw_close(trim(memfile)//'.nc', ncid) -end subroutine - - - -end module m_put_micom_fld - - diff --git a/assim/enkf_cf-system2_old/EnKF/m_random.F90 b/assim/enkf_cf-system2_old/EnKF/m_random.F90 deleted file mode 100755 index e9e90f59..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_random.F90 +++ /dev/null @@ -1,51 +0,0 @@ -module m_random - -contains - - subroutine random(work1,n) - ! Returns a vector of random values N(variance=1,mean=0) - implicit none - integer, intent(in) :: n - real, intent(out) :: work1(n) - real, allocatable :: work2(:) - real, parameter :: pi=3.141592653589 - - allocate (work2(n)) - - call random_number(work1) - call random_number(work2) - work1= sqrt(-2.0*log(work1))*cos(2.0*pi*work2) - - deallocate(work2) - end subroutine random - - - subroutine randn(n, vect) - implicit none - integer, intent(in) :: n - real, intent(out) :: vect(n) - - integer :: i - real :: a(2), r - - i = 0 - do while (i < n) - call random_number(a) - a = 2.0 * a - 1.0 - r = a(1) * a(1) + a(2) * a(2) - if (r > 1.0) then - cycle - end if - i = i + 1 - ! assume that r is never equal to 0 - PS - r = sqrt(-2.0 * log(r) / r); - vect(i) = r * a(1); - if (i == n) then - exit - end if - i = i + 1 - vect(i) = r * a(2); - end do - end subroutine randn - -end module m_random diff --git a/assim/enkf_cf-system2_old/EnKF/m_set_random_seed2.F90 b/assim/enkf_cf-system2_old/EnKF/m_set_random_seed2.F90 deleted file mode 100755 index fade09c4..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_set_random_seed2.F90 +++ /dev/null @@ -1,89 +0,0 @@ -module m_set_random_seed2 -contains -subroutine set_random_seed2 -! Sets a random seed based on the system and wall clock time -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - - integer , dimension(8)::val - integer cnt - integer sze - integer, allocatable, dimension(:):: pt -#if defined (QMPI) - integer :: q -#endif - - call DATE_AND_TIME(values=val) - if(master)print*,'TIME', val - call SYSTEM_CLOCK(count=cnt) - if(master)print*,'CLOCK', cnt - call RANDOM_SEED(size=sze) - if(master)print*,'SEED', sze - allocate(pt(sze)) - pt(1) = val(8)*val(3) - pt(2) = cnt - ! KAL --- spread random seed to tiles, this makes sure that m_sample2D - ! KAL --- produces the same perturbations across processes -#if defined (QMPI) - if (master) then - do q=2,qmpi_num_proc - call send(pt,q-1) - end do - else - call receive(pt,0) - end if -#endif - call RANDOM_SEED(put=pt) - if(master)print*,'RANDOM SEED', pt - deallocate(pt) -end subroutine set_random_seed2 - -! --- Sets a random seed based on the wall clock time - subroutine set_random_seed3 -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - integer , dimension(8)::val - integer cnt,q - integer sze -! --- Arrays for random seed - integer, allocatable, dimension(:):: pt - real , allocatable, dimension(:):: rpt -! - call DATE_AND_TIME(values=val) - call RANDOM_SEED(size=sze) - allocate(pt(sze)) - allocate(rpt(sze)) -! --- Init - assumes seed is set in some way based on clock, -! --- date etc. (not specified in fortran standard). Sometimes -! --- this initial seed is just set every second - call RANDOM_SEED -! --- Retrieve initialized seed. val(8) is milliseconds - - call RANDOM_SEED(GET=pt) -! --- this randomizes stuff if random_seed is not updated often -! --- enough. synchronize seed across tasks (needed if pseudo -! --- is paralellized some day) - rpt = pt * (val(8)-500) -#if defined (QMPI) - if (master) then - do q=2,qmpi_num_proc - call send(rpt,q-1) - end do - else - call receive(rpt,0) - end if -#endif - pt=int(rpt) - call RANDOM_SEED(put=pt) - deallocate( pt) - deallocate(rpt) - end subroutine set_random_seed3 - -end module m_set_random_seed2 diff --git a/assim/enkf_cf-system2_old/EnKF/m_spherdist.F90 b/assim/enkf_cf-system2_old/EnKF/m_spherdist.F90 deleted file mode 100755 index 684ac508..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_spherdist.F90 +++ /dev/null @@ -1,28 +0,0 @@ -module m_spherdist - -contains - - ! Computes the distance between geo. pos. lon1, lat1 and lon2, lat2. - ! http://en.wikipedia.org/wiki/Great-circle_distance - ! - ! Input is in degrees, output in meters - ! - ! -real function spherdist(lon1, lat1, lon2, lat2) - implicit none - - real(8), intent(in) :: lon1, lat1, lon2, lat2 ! pos. in degrees - - real(8), parameter :: INVRAD = 3.14159265358979323846d0 / 180.0d0 - real, parameter :: REARTH = 6371000.0d0 - real :: rlon1, rlat1, rlon2, rlat2 ! pos. in radians - - rlon1 = lon1 * INVRAD !lon1 in rad - rlat1 = lat1 * INVRAD !90-lat1 in rad - rlon2 = lon2 * INVRAD ! lon2 in rad - rlat2 = lat2 * INVRAD !90 - lat2 in rad - spherdist = REARTH * acos(min(max(sin(rlat1) * sin(rlat2)& - + cos(rlat1) * cos(rlat2) * cos(rlon1 - rlon2),-1.),1.)) -end function spherdist - -end module m_spherdist diff --git a/assim/enkf_cf-system2_old/EnKF/m_uobs.F90 b/assim/enkf_cf-system2_old/EnKF/m_uobs.F90 deleted file mode 100755 index 5f5dfb44..00000000 --- a/assim/enkf_cf-system2_old/EnKF/m_uobs.F90 +++ /dev/null @@ -1,105 +0,0 @@ -! File: m_uobs.F90 -! -! Created: 11 August 2010 -! -! Last modified: 11.8.2010 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Handle different observation types. -! -! Description: This module is in charge of sorting of observations by types -! and storing the results -! -! Modifications: None - -module m_uobs -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - use mod_measurement - implicit none - - public uobs_get - - integer, parameter, private :: MAXNUOBS = 9 - - integer, public :: nuobs - character(OBSTYPESTRLEN), public :: unique_obs(MAXNUOBS) - integer, public :: nobseach(MAXNUOBS) - integer :: uobs_begin(MAXNUOBS), uobs_end(MAXNUOBS) - -contains - - subroutine uobs_get(tags, nrobs, master) - implicit none - integer , intent(in) :: nrobs - logical , intent(in) :: master - character(OBSTYPESTRLEN), intent(in) :: tags(nrobs) - - logical :: obsmatch - integer :: o, uo - - nobseach = 0 - - ! check for unique obs - if (master) then - print '(a)', ' EnKF: getting unique observations ' - end if - nuobs = 0 - unique_obs = '' - do o = 1, nrobs - obsmatch = .false. - do uo = 1, nuobs - if (trim(tags(o)) == trim(unique_obs(uo))) then - obsmatch = .true. - nobseach(uo) = nobseach(uo) + 1 - exit - end if - end do - if (.not. obsmatch) then - nuobs = nuobs + 1 - nobseach(nuobs) = 1 - if (nuobs > MAXNUOBS) then - if (master) then - print *, 'ERROR: uobs_get(): # of unique obs = ', nuobs,& - ' > MAXNUOBS = ', MAXNUOBS - print *, ' obs # = ', o, ', tag = ', trim(tags(o)) - end if - stop - end if - unique_obs(nuobs) = trim(tags(o)) - end if - end do - if (master) then - do uo = 1, nuobs - print '(a, i2, a, a, a, i7, a)', ' obs variable ', uo, ' -- ',& - trim(unique_obs(uo)), ',', nobseach(uo), ' observations' - end do - end if - uobs_begin(1) = 1 - uobs_end(1) = nobseach(1) - do uo = 2, nuobs - uobs_begin(uo) = uobs_end(uo - 1) + 1 - uobs_end(uo) = uobs_begin(uo) + nobseach(uo) - 1 - end do - if (master) then - do uo = 1, nuobs - do o = uobs_begin(uo), uobs_end(uo) - if (trim(tags(o)) /= trim(unique_obs(uo))) then - print *, 'ERROR: uobs_get(): uinique observations not ',& - 'continuous in observation array' - stop - end if - end do - end do - end if - if (master) then - print * - end if - end subroutine uobs_get - -end module m_uobs diff --git a/assim/enkf_cf-system2_old/EnKF/makefile b/assim/enkf_cf-system2_old/EnKF/makefile deleted file mode 100755 index dda3ee76..00000000 --- a/assim/enkf_cf-system2_old/EnKF/makefile +++ /dev/null @@ -1,83 +0,0 @@ -MPI = YES -VPATH = .:TMP:../shared - -include make.inc.$(MACH) - -SHELL = /bin/bash - -PROGS = EnKF - -all: $(PROGS) - -ENKF_SRC_F90 = \ -qmpi.F90\ -m_parameters.F90\ -m_get_micom_dim.F90\ -m_get_cice_dim.F90\ -m_get_mod_fld.F90\ -m_get_micom_fld.F90\ -m_get_micom_grid.F90\ -m_get_micom_nrens.F90\ -spline.F90\ -m_Generate_element_Si.F90\ -mod_analysisfields.F90\ -m_confmap.F90\ -mod_measurement.F90\ -m_oldtonew.F90\ -m_random.F90\ -m_spherdist.F90\ -distribute.F90\ -m_bilincoeff.F90\ -m_insitu.F90\ -m_local_analysis.F90\ -m_obs.F90\ -m_parse_blkdat.F90\ -m_pivotp.F90\ -m_point2nc.F90\ -m_prep_4_EnKF.F90\ -m_put_micom_fld.F90\ -m_set_random_seed2.F90\ -m_uobs.F90\ -nfw.F90\ -EnKF.F90 - -ENKF_SRC_F77 = mod_raw_io.F eosdat.F mod_eosfun.F - -ENKF_SRC_C = order.c - -ENKF_OBJ = $(ENKF_SRC_C:.c=.o) $(ENKF_SRC_F77:.F=.o) $(ENKF_SRC_F90:.F90=.o) - -# some fine tuning; add more dependancies when/if required -# -m_obs.o: m_uobs.o -m_get_micom_grid.o : nfw.o -m_get_micom_dim.o : nfw.o -m_Generate_element_Si.o: m_parse_blkdat.o mod_measurement.o m_get_mod_fld.o m_insitu.o m_obs.o -m_insitu.o: nfw.o mod_measurement.o -m_local_analysis.o: mod_measurement.o m_point2nc.o m_parameters.o - -EnKF: $(ENKF_OBJ) - @echo "->EnKF" - @echo $(LD) $(LINKFLAGS) -o ../../../EnKF $(ENKF_OBJ) $(LIBS) - @cd ./TMP ; $(LD) $(LINKFLAGS) -o ../../../EnKF $(ENKF_OBJ) $(LIBS) - -$(ENKF_OBJ): makefile MODEL.CPP - -clean: - @rm -f TMP/*.* $(PROGS) - -%.o: %.F90 - @echo " $*".F90 - @rm -f ./TMP/$*.f90 - @cat MODEL.CPP $*.F90 | $(CPP) $(CPPFLAGS) > ./TMP/$*.f90 - @cd ./TMP ; $(CF90) -c $(FFLAGS) $(F90FLG) -o $*.o $*.f90 - -%.o: %.F - @echo " $*".F - @rm -f ./TMP/$*.f - @cat MODEL.CPP $*.F | $(CPP) $(CPPFLAGS) > ./TMP/$*.f - @cd ./TMP ; $(CF77) -c $(FFLAGS) $(F77FLG) -o $*.o $*.f - -%.o: %.c - @echo " $*".c - @cd ./TMP ; $(CC) -c $(CFLAGS) -o $*.o -I.. ../$*.c diff --git a/assim/enkf_cf-system2_old/EnKF/mod_analysisfields.F90 b/assim/enkf_cf-system2_old/EnKF/mod_analysisfields.F90 deleted file mode 100755 index 917dc1e6..00000000 --- a/assim/enkf_cf-system2_old/EnKF/mod_analysisfields.F90 +++ /dev/null @@ -1,140 +0,0 @@ -!KAL -- this module allows us to fine-tune the fields -!KAL -- we wish to include in tha analysis. The new -!KAL -- layout of the EnKF makes it possible to specify fields -!KAL -- to analyze at run-time rather than at compile-time -!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -!KAL -- -!KAL -- Module variables: -!KAL -- numfields - total number of fields to process -!KAL -- fieldnames - the names of the fields we wish to analyze -!KAL -- fieldlevel - the levels of the associated fields -!KAL -- -!KAL -- Ex: If we only want to assimilate temperatures in layer -!KAL -- one and two, numfields, fieldnames and fieldlevel -!KAL -- would look like: -!KAL -- -!KAL -- numfields=2 -!KAL -- fieldnames (1)='temp', fieldnames (2)='temp' -!KAL -- fieldlevel (1)= 1, fieldlevel (2)=2 -!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -!KAL -- The file "analysisfields.in" specifies the fields to -!KAL -- inlude in the analysis. Format of one line is fieldname -!KAL -- first layer and last layer, example -!KAL -- -!KAL -- fldname 1 22 -!KAL -- 12345678901234567890123456789012345678901234567890 -!KAL -- -!KAL -- Fortran format for one line is '(a8,2i3)' -!KAL -- -!KAL -- Example: to specify that we want temperature and salinity -!KAL -- in layers 1..22 to be updated, as well as -!KAL -- ice concentration (layer 0), specify: -!KAL -- -!KAL -- saln 1 22 -!KAL -- temp 1 22 -!KAL -- hice 0 0 -!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -module mod_analysisfields - -character(len=*), parameter :: infile='analysisfields.in' -integer :: numfields -character(len=8), dimension(:), allocatable:: fieldnames -integer , dimension(:), allocatable:: fieldlevel -character(len=2), dimension(:), allocatable:: rstcode - -contains - - integer function get_nrfields() -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - integer :: ios,first,last - logical :: ex - character(len=9) :: char9 - character(len=2) :: char2 - - inquire(exist=ex,file=infile) - if (.not. ex) then - if (master) print *,'Could not find '//infile - call stop_mpi() - end if - - open(10,status='old',form='formatted',file=infile) - ios=0 - get_nrfields=0 - do while (ios==0) - read(10,100,iostat=ios) char9,first,last,char2 - if (ios==0) get_nrfields=get_nrfields+last-first+1 - end do - close(10) - 100 format (a9,2i3,a2) - end function - - subroutine get_analysisfields() -#if defined (QMPI) - use qmpi -#else - use qmpi_fake -#endif - implicit none - integer :: first,last,k,nfld,ios - logical :: ex - character(len=9) :: char9 - character(len=2) :: char2 - - numfields=get_nrfields() - if (master) print *,'numfields is ',numfields - if (numfields<=0 .or.numfields > 16000) then ! - if (master) print *,'numfields is higher than max allowed setting or = 0' - call stop_mpi() - end if - allocate(fieldnames(numfields)) - allocate(fieldlevel(numfields)) - allocate(rstcode(numfields)) - - - inquire(exist=ex,file=infile) - if (.not. ex) then - if (master) print *,'Could not find '//infile - call stop_mpi() - end if - - open(10,status='old',form='formatted',file=infile) - ios=0 - nfld=0 - do while (ios==0) - read(10,100,iostat=ios) char9,first,last,char2 - if (ios==0) then - do k=first,last - fieldnames (nfld+k-first+1)=char9 - fieldlevel (nfld+k-first+1)=k - rstcode (nfld+k-first+1)=char2 - end do - nfld=nfld+last-first+1 - end if - end do - close(10) - 100 format (a9,2i3,a2) - - if (nfld/=numfields) then - if (master) print *,'An error occured when reading '//infile - call stop_mpi() - end if - - ! List fields used in analysis - do k=1,numfields - if (master) print *,fieldnames(k),fieldlevel(k),rstcode(k) - end do - - end subroutine -end module mod_analysisfields - - - - - - diff --git a/assim/enkf_cf-system2_old/EnKF/mod_eosfun.F b/assim/enkf_cf-system2_old/EnKF/mod_eosfun.F deleted file mode 100755 index 100df5d1..00000000 --- a/assim/enkf_cf-system2_old/EnKF/mod_eosfun.F +++ /dev/null @@ -1,420 +0,0 @@ - module mod_eosfun - - contains - - - subroutine eosini -c - implicit none -c -#include "common_eos.h" -c -c --- In situ density [kg/m^3] as a function of pressure, potential -c --- temperature and salinity is approximated by the functional form -c --- rho(p,th,s)=P1(p,th,s)/P2(p,th,s) -c --- where -c --- P1(p,th,s)=a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s+(b11+b12*th+b13*s)*p -c --- and -c --- P2(p,th,s)=a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s+(b21+b22*th+b23*s)*p -c --- Here we compute the coefficients needed for an expression for -c --- potential density [g/cm^3] in sigma units of the form -c --- sig(th,s)=R1(th,s)/R2(th,s) -c --- where -c --- R1(p,th,s)=ap11+(ap12+ap14*th+ap15*s)*th+(ap13+ap16*s)*s -c --- and -c --- R2(p,th,s)=ap21+(ap22+ap24*th+ap25*s)*th+(ap23+ap26*s)*s -c - ap21=a21+b21*pref - ap22=a22+b22*pref - ap23=a23+b23*pref - ap24=a24 - ap25=a25 - ap26=a26 - ap11=a11+b11*pref-ap21 - ap12=a12+b12*pref-ap22 - ap13=a13+b13*pref-ap23 - ap14=a14-ap24 - ap15=a15-ap25 - ap16=a16-ap26 -c - ap210=a21 - ap220=a22 - ap230=a23 - ap240=a24 - ap250=a25 - ap260=a26 - ap110=a11-ap210 - ap120=a12-ap220 - ap130=a13-ap230 - ap140=a14-ap240 - ap150=a15-ap250 - ap160=a16-ap260 -c - return - end -c - -c --- ------------------------------------------------------------------ - subroutine settemmin(idm,jdm,kdm,sigmar,temmin) -c -c --- ------------------------------------------------------------------ -c --- Set minimum physical temperature values in isopycnic layers -c --- ------------------------------------------------------------------ -c -c - implicit none -c - integer, intent(in) :: idm,jdm,kdm - real, dimension(idm,jdm,kdm), intent(in) :: sigmar - real, dimension(idm,jdm,kdm), intent(inout) :: temmin -#include "common_eos.h" - integer i,j,k,l - real gam,salfrz,a,b,c -c -c --- Let temmin be the freezing temperature of a given potential -c --- density. This can be achieved by using potential density given in -c --- the function sig and the salinity dependent freezing temperature -c --- given in the function swtfrz. -c - gam=-.0547 - do k=2,kdm - do j=1,jdm - do i=1,idm - a=((ap14-ap24*sigmar(i,j,k))*gam - . + ap15-ap25*sigmar(i,j,k) )*gam - . +ap16-ap26*sigmar(i,j,k) - b=(ap12-ap22*sigmar(i,j,k))*gam+ap13-ap23*sigmar(i,j,k) - c=ap11-ap21*sigmar(i,j,k) - salfrz=(-b+sqrt(b*b-4.*a*c))/(2.*a) - temmin(i,j,k)=gam*salfrz - enddo - enddo - enddo - return - end -c --- ------------------------------------------------------------------ -c - real function rho(p,th,s) -c - implicit none -c - real p,th,s -c -#include "common_eos.h" -c - rho=(a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s+(b11+b12*th+b13*s)*p) - . /(a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s+(b21+b22*th+b23*s)*p) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function alp(p,th,s) -c - implicit none -c - real p,th,s -c -#include "common_eos.h" -c - alp=(a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s+(b21+b22*th+b23*s)*p) - . /(a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s+(b11+b12*th+b13*s)*p) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function sig(th,s) -c -c --- potential density [g/cm^3] in sigma units as a function of -c --- potential temperature and salinity -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - sig=(ap11+(ap12+ap14*th+ap15*s)*th+(ap13+ap16*s)*s) - . /(ap21+(ap22+ap24*th+ap25*s)*th+(ap23+ap26*s)*s) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function sig0(th,s) -c -c --- potential density [g/cm^3] with reference pressure at the surface -c --- in sigma units as a function of potential temperature and salinity -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - sig0=(ap110+(ap120+ap140*th+ap150*s)*th+(ap130+ap160*s)*s) - . /(ap210+(ap220+ap240*th+ap250*s)*th+(ap230+ap260*s)*s) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function dsigdt(th,s) -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - real r1,r2i -c - r1=ap11+(ap12+ap14*th+ap15*s)*th+(ap13+ap16*s)*s - r2i=1./(ap21+(ap22+ap24*th+ap25*s)*th+(ap23+ap26*s)*s) -c - dsigdt=(ap12+2.*ap14*th+ap15*s - . -(ap22+2.*ap24*th+ap25*s)*r1*r2i)*r2i -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function dsigdt0(th,s) -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - real r1,r2i -c - r1=ap110+(ap120+ap140*th+ap150*s)*th+(ap130+ap160*s)*s - r2i=1./(ap210+(ap220+ap240*th+ap250*s)*th+(ap230+ap260*s)*s) -c - dsigdt0=(ap120+2.*ap140*th+ap150*s - . -(ap220+2.*ap240*th+ap250*s)*r1*r2i)*r2i -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function dsigds(th,s) -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - real r1,r2i -c - r1=ap11+(ap12+ap14*th+ap15*s)*th+(ap13+ap16*s)*s - r2i=1./(ap21+(ap22+ap24*th+ap25*s)*th+(ap23+ap26*s)*s) -c - dsigds=(ap13+ap15*th+2.*ap16*s - . -(ap23+ap25*th+2.*ap26*s)*r1*r2i)*r2i -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function dsigds0(th,s) -c - implicit none -c - real th,s -c -#include "common_eos.h" -c - real r1,r2i -c - r1=ap110+(ap120+ap140*th+ap150*s)*th+(ap130+ap160*s)*s - r2i=1./(ap210+(ap220+ap240*th+ap250*s)*th+(ap230+ap260*s)*s) -c - dsigds0=(ap130+ap150*th+2.*ap160*s - . -(ap230+ap250*th+2.*ap260*s)*r1*r2i)*r2i -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function tofsig(sg,s) -c - implicit none -c - real sg,s -c -#include "common_eos.h" -c - real a,b,c -c - a=ap14-ap24*sg - b=ap12-ap22*sg+(ap15-ap25*sg)*s - c=ap11-ap21*sg+(ap13-ap23*sg+(ap16-ap26*sg)*s)*s -c - tofsig=(-b-sqrt(b*b-4.*a*c))/(2.*a) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function sofsig(sg,th) -c - implicit none -c - real sg,th -c -#include "common_eos.h" -c - real a,b,c -c - a=ap16-ap26*sg - b=ap13-ap23*sg+(ap15-ap25*sg)*th - c=ap11-ap21*sg+(ap12-ap22*sg+(ap14-ap24*sg)*th)*th -c - sofsig=(-b+sqrt(b*b-4.*a*c))/(2.*a) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function p_alpha(p1,p2,th,s) -c -c --- integrate specific volume with respect to pressure -c - implicit none -c - real p1,p2,th,s -c -#include "common_eos.h" -c - real r1_3,r1_5,r1_7,r1_9 - parameter (r1_3=1./3.,r1_5=1./5.,r1_7=1./7.,r1_9=1./9.) -c - real a1,a2,b1,b2,pm,r,q,qq -c - a1=a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s - a2=a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s - b1=b11+b12*th+b13*s - b2=b21+b22*th+b23*s -c -c --- the analytic solution of the integral is -c p_alpha=(b2*(p2-p1) -c +(a2-a1*b2/b1)*log((a1+b1*p2)/(a1+b1*p1)))/b1 -c --- a truncated series expansion of the integral is used that provide -c --- better computational efficiency and accuarcy for most relevant -c --- parameters -c - pm=.5*(p2+p1) - r=.5*(p2-p1)/(a1+b1*pm) - q=b1*r - qq=q*q -c - p_alpha=2.*r*(a2+b2*pm - . +(a2-a1*b2/b1)*qq*(r1_3+qq*(r1_5+qq*(r1_7+qq*r1_9)))) -c - return - end -c -c --- ------------------------------------------------------------------ -c - real function p_p_alpha(p1,p2,th,s) -c -c --- double integration of specific volume with respect to pressure -c - implicit none -c - real p1,p2,th,s -c -#include "common_eos.h" -c - real r1_3,r1_5,r1_7,r1_9,r1_10 - parameter (r1_3=1./3.,r1_5=1./5.,r1_7=1./7.,r1_9=1./9., - . r1_10=1./10.) -c - real a1,a2,b1,b2,pm,dp,r,q -c - a1=a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s - a2=a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s - b1=b11+b12*th+b13*s - b2=b21+b22*th+b23*s -c -c --- the analytic solution of the integral is -c p_p_alpha=(.5*b2*(p2-p1)**2 -c +(a2-a1*b2/b1)*((a1/b1+p2)*log((a1+b1*p2)/(a1+b1*p1)) -c -(p2-p1)))/b1 -c --- a truncated series expansion of the integral is used that provide -c --- better computational efficiency and accuarcy for most relevant -c --- parameters -c - pm=.5*(p2+p1) - dp=.5*(p2-p1) - r=dp/(a1+b1*pm) - q=b1*r -c - p_p_alpha=2.*dp*r*(a2+b2*pm - . +(a2-a1*b2/b1)*q*(r1_3+q*(r1_3+ - . q*(r1_5+q*(r1_5+ - . q*(r1_7+q*(r1_7+ - . q*(r1_9+q*(r1_9+ - . q* r1_10))))))))) -c - return - end -c -c --- ------------------------------------------------------------------ -c - subroutine delphi(p1,p2,th,s,dphi,alp1,alp2) -c -c --- integrate specific volume with respect to pressure to find the -c --- difference in geopotential between two pressure levels -c - implicit none -c - real p1,p2,th,s,dphi,alp1,alp2 -c -#include "common_eos.h" -c - real r1_3,r1_5,r1_7,r1_9 - parameter (r1_3=1./3.,r1_5=1./5.,r1_7=1./7.,r1_9=1./9.) -c - real a1,a2,b1,b2,pm,r,q,qq -c - a1=a11+(a12+a14*th+a15*s)*th+(a13+a16*s)*s - a2=a21+(a22+a24*th+a25*s)*th+(a23+a26*s)*s - b1=b11+b12*th+b13*s - b2=b21+b22*th+b23*s -c -c --- the analytic solution of the integral is -c dphi=-(b2*(p2-p1) -c +(a2-a1*b2/b1)*log((a1+b1*p2)/(a1+b1*p1)))/b1 -c --- a truncated series expansion of the integral is used that provide -c --- better computational efficiency and accuarcy for most relevant -c --- parameters -c - pm=.5*(p2+p1) - r=.5*(p2-p1)/(a1+b1*pm) - q=b1*r - qq=q*q -c - dphi=-2.*r*(a2+b2*pm - . +(a2-a1*b2/b1)*qq*(r1_3+qq*(r1_5+qq*(r1_7+qq*r1_9)))) -c - alp1=(a2+b2*p1)/(a1+b1*p1) - alp2=(a2+b2*p2)/(a1+b1*p2) -c - return - end - end module mod_eosfun diff --git a/assim/enkf_cf-system2_old/EnKF/mod_measurement.F90 b/assim/enkf_cf-system2_old/EnKF/mod_measurement.F90 deleted file mode 100755 index f99926e4..00000000 --- a/assim/enkf_cf-system2_old/EnKF/mod_measurement.F90 +++ /dev/null @@ -1,32 +0,0 @@ -module mod_measurement - - integer, parameter, public :: OBSTYPESTRLEN = 5 - - type measurement - real d ! Measurement value - real var ! Error variance of measurement - character(len=OBSTYPESTRLEN) id ! Type, can be one of those: - ! 'SST' 'SLA' 'ICEC' 'SAL' 'TEM' - ! 'GSAL' 'GTEM' 'TSLA' - real lon ! Longitude position - real lat ! Latitude position - real depth ! depths of position - integer ipiv ! i-pivot point in grid - integer jpiv ! j-pivot point in grid - integer ns ! representativity in mod cells (meas. support) - ! ns=0 means: point measurements - ! used in m_Generate_element_Sij.F90 - real a1 ! bilinear coefficient (for ni=0) - real a2 ! bilinear coefficient - real a3 ! bilinear coefficient - real a4 ! bilinear coefficient - logical status ! active or not - integer i_orig_grid ! KAL - orig grid index for ice drift - ! processing - integer j_orig_grid ! orig grid index - real h ! PS - layer thickness, sorry for that - integer date ! FanF - age of the data - integer orig_id ! PS - used in superobing - end type measurement - -end module mod_measurement diff --git a/assim/enkf_cf-system2_old/EnKF/mod_raw_io.F b/assim/enkf_cf-system2_old/EnKF/mod_raw_io.F deleted file mode 100755 index ff45a35b..00000000 --- a/assim/enkf_cf-system2_old/EnKF/mod_raw_io.F +++ /dev/null @@ -1,392 +0,0 @@ - module mod_raw_io - contains - - -! Modified from Alan Wallcraft's RAW routine by Knut Liseter @ NERSC -! So far only the "I" in "IO" is present - SUBROUTINE READRAW(A,AMN,AMX,IDM,JDM,LSPVAL,SPVAL,CFILE1,K) - IMPLICIT NONE -C - REAL*4 SPVALH - PARAMETER (SPVALH=1.0E30_4) -C - REAL*4, INTENT(OUT) :: A(IDM,JDM) - REAL*4, INTENT(OUT) :: AMN,AMX - INTEGER, INTENT(IN) :: IDM,JDM - LOGICAL, INTENT(IN) :: LSPVAL - REAL*4, INTENT(INOUT) :: SPVAL - INTEGER, INTENT(IN) :: K - CHARACTER(len=*), INTENT(IN) :: CFILE1 -C - REAL*4 :: PADA(4096) -C -C MOST OF WORK IS DONE HERE. -C - - INTEGER LEN_TRIM - INTEGER I,J,IOS,NRECL - INTEGER NPAD -C - IF(.NOT.LSPVAL) THEN - SPVAL = SPVALH - ENDIF -C -!!! Calculate the number of elements padded!!!!!!!!!!!!!!!!!!!!!!!! - NPAD=GET_NPAD(IDM,JDM) -C - INQUIRE( IOLENGTH=NRECL) A,PADA(1:NPAD) -C -C - OPEN(UNIT=11, FILE=CFILE1, FORM='UNFORMATTED', STATUS='old', - + ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS) - IF (IOS.NE.0) THEN - write(6,*) 'Error: can''t open ',CFILE1(1:LEN_TRIM(CFILE1)) - write(6,*) 'ios = ',ios - write(6,*) 'nrecl = ',nrecl - CALL EXIT(3) - ENDIF -C - READ(11,REC=K,IOSTAT=IOS) A - close(11) -C - IF (IOS.NE.0) THEN - WRITE(6,*) 'can''t read record ',K, - & ' from '//CFILE1(1:LEN_TRIM(CFILE1)) - CALL EXIT(4) - ENDIF -C - AMN = SPVALH - AMX = -SPVALH - DO J= 1,JDM - DO I=1,IDM - IF (A(I,J).LE.SPVALH) THEN - AMN = MIN(real(AMN, 4), real(A(I,J), 4)) - AMX = MAX(real(AMX, 4), real(A(I,J), 4)) - ELSEIF (LSPVAL) THEN - A(I,J) = SPVAL - ENDIF - END DO - END DO -C - RETURN - END SUBROUTINE - -! Modified from Alan Wallcraft's RAW routine by Knut Liseter @ NERSC -! This wll be the "O" in "IO" is present - SUBROUTINE WRITERAW(A,AMN,AMX,IDM,JDM,LSPVAL,SPVAL,CFILE1,K) - IMPLICIT NONE -C - REAL*4 SPVALH - PARAMETER (SPVALH=1.0e30_4) -C - REAL*4, INTENT(INOUT) :: A(IDM,JDM) - REAL*4, INTENT(OUT) :: AMN,AMX - INTEGER, INTENT(IN) :: IDM,JDM - LOGICAL, INTENT(IN) :: LSPVAL - REAL*4, INTENT(INOUT) :: SPVAL - INTEGER, INTENT(IN) :: K - CHARACTER(len=*), INTENT(IN) :: CFILE1 -C - REAL*4 :: PADA(4096) -C -C MOST OF WORK IS DONE HERE. -C - - INTEGER LEN_TRIM - INTEGER I,J,IOS,NRECL - INTEGER NPAD -C - IF(.NOT.LSPVAL) THEN - SPVAL = SPVALH - ENDIF -C -!!! Calculate the number of elements padded!!!!!!!!!!!!!!!!!!!!!!!! - NPAD=GET_NPAD(IDM,JDM) -C - PADA=0. - INQUIRE( IOLENGTH=NRECL) A,PADA(1:NPAD) -C -C - OPEN(UNIT=11, FILE=CFILE1, FORM='UNFORMATTED', STATUS='unknown', - + ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS) - IF (IOS.NE.0) THEN - write(6,*) 'Error: can''t open ',CFILE1(1:LEN_TRIM(CFILE1)) - write(6,*) 'ios = ',ios - write(6,*) 'nrecl = ',nrecl - CALL EXIT(3) - ENDIF -C - WRITE(11,REC=K,IOSTAT=IOS) A,PADA(1:NPAD) - close(11) -C - IF (IOS.NE.0) THEN - WRITE(6,*) 'can''t write record ',K, - & ' from '//CFILE1(1:LEN_TRIM(CFILE1)) - CALL EXIT(4) - ENDIF -C - AMN = SPVALH - AMX = -SPVALH - DO J= 1,JDM - DO I=1,IDM - IF (A(I,J).LE.SPVALH) THEN - AMN = MIN(real(AMN, 4), real(A(I,J), 4)) - AMX = MAX(real(AMX, 4), real(A(I,J), 4)) - ELSEIF (LSPVAL) THEN - A(I,J) = SPVAL - ENDIF - END DO - END DO -C - RETURN - END SUBROUTINE - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Routine to get index of fields in data file (.a) from header file (.b) - subroutine rst_index_from_header(fname,cfld,vlevel,tlevel, - & indx,bmin,bmax,skiphdr) - implicit none - character(len=*), intent(in) :: fname ! filename without extention - character(len=*), intent(in) :: cfld ! variable name - integer , intent(in) :: tlevel ! time level - integer , intent(in) :: vlevel ! vertical level - integer , intent(out):: indx ! index in .a file - real , intent(out):: bmin,bmax ! min and max from b file - logical , intent(in) :: skiphdr - - integer :: itlevel, ivlevel - character(len=8) :: icfld - integer :: ios,i - integer :: nskip_rst,nop - logical :: match, ex - - nskip_rst=2 - nop = 999 - - ! Open file - inquire(exist=ex,file=trim(fname)) - if (.not. ex) then - print *,'file '//trim(fname)//' is not present' - call exit(1) - end if - open(nop,file=trim(fname),status='old') - - ! Skip first nskip lines - if (skiphdr) then - do i=1,nskip_rst - read(nop,*) - end do - end if - - match=.false. - indx=0 - ios=0 - do while (ios==0 .and. .not.match) - read(nop,117,iostat=ios) icfld,ivlevel,itlevel,bmin,bmax - match= icfld==cfld .and. ivlevel==vlevel .and. itlevel==tlevel - indx=indx+1 - !print *,icfld,itlevel,ivlevel,bmin,bmax - end do - - close(nop) - - if (.not.match) then - !print *,'Could not find field '//cfld - !print *,'Vertical level :',vlevel - !print *,'Time level :',tlevel - indx=-1 - !call exit(1) ! Always return to caller - endif - - 117 format (a8,23x,i3,i3,2x,2e16.7) - - end subroutine - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Routine to get field desc in header file (.b) from index in data file (.a) - subroutine rst_header_from_index(fname,cfld,vlevel,tlevel, - & indx,bmin,bmax,skiphdr) - implicit none - character(len=*), intent(in) :: fname ! filename without extention - character(len=8), intent(out) :: cfld ! variable name - integer , intent(out) :: tlevel ! time level - integer , intent(out) :: vlevel ! vertical level - integer , intent(in) :: indx ! index in .a file - real , intent(out) :: bmin,bmax ! min and max from b file - logical , intent(in ) :: skiphdr ! Skip header of .b file - - integer :: ios,i - integer :: nskip_rst,nop - logical :: ex - - - nskip_rst=2 - nop = 999 - - ! Open file - inquire(exist=ex,file=trim(fname)) - if (.not. ex) then - print *,'file '//trim(fname)//' not present' - call exit(1) - end if - open(nop,file=trim(fname),status='old') - - ! Skip first nskip + index-1 lines - !print *,'hei' - if (skiphdr) then - do i=1,nskip_rst - read(nop,*) - end do - end if - do i=1,indx-1 - read(nop,*) - end do - read(nop,117,iostat=ios) cfld,vlevel,tlevel,bmin,bmax - close(nop) - - if (ios/=0) then - !print *,'Could not get info from index',indx - !call exit(1) - cfld='' - tlevel=-1 - vlevel=-1 - endif - - 117 format (a8,23x,i3,i3,2x,2e16.7) - - end subroutine - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Routine to get index of fields in regional grid file (.a) from header file (.b) - subroutine grid_index_from_header(fname,cfld,indx,bmin,bmax - & ,skiphdr) - implicit none - character(len=*), intent(in) :: fname ! filename without extention - character(len=*), intent(in) :: cfld ! variable name - integer , intent(out):: indx ! index in .a file - real , intent(out):: bmin,bmax ! min and max from b file - logical , intent(in) :: skiphdr - - character(len=4) :: icfld - character*80 :: cline - integer :: ios,i - integer :: nskip_grid,nop - logical :: match, ex - - nskip_grid=3 - nop = 999 - - ! Open file - inquire(exist=ex,file=trim(fname)) - if (.not. ex) then - print *,'file '//trim(fname)//' is not present' - call exit(1) - end if - open(nop,file=trim(fname),status='old') - - ! Skip first nskip lines - if (skiphdr) then - do i=1,nskip_grid - read(nop,*) - end do - end if - - match=.false. - indx=0 - ios=0 - do while (ios==0 .and. .not.match) - read(nop,'(a)') cline - icfld=cline(1:4) - i=index(cline,'=') - read (cline(i+1:),*) bmin,bmax - match= trim(icfld)==trim(cfld) - indx=indx+1 - end do - - close(nop) - - if (.not.match) then - indx=-1 - endif - end subroutine grid_index_from_header - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Routine to get index of fields in regional grid file (.a) from header file (.b) - subroutine daily_index_from_header(fname,cfld,coord,indx, - & bmin,bmax) - implicit none - character(len=*), intent(in) :: fname ! filename without extention - character(len=*), intent(in) :: cfld ! variable name - integer , intent(in) :: coord ! vertical coordinate - integer , intent(out):: indx ! index in .a file - real , intent(out):: bmin,bmax ! min and max from b file - - logical, parameter:: skiphdr=.true. - character(len=5) :: char5 - character(len=8) :: char8 - integer :: ios - integer :: nop - logical :: match, ex - real :: dens,rday - integer :: lcoord,nstep - - nop = 999 - - ! Open file - inquire(exist=ex,file=trim(fname)) - if (.not. ex) then - print *,'file '//trim(fname)//' is not present' - call exit(1) - end if - open(nop,file=trim(fname),status='old') - - ! Skip first nskip lines - if (skiphdr) then - do while (char5/='field' .and. ios==0) - read(nop,'(a5)',iostat=ios) char5 - end do - end if - - ! Read until we get the field we want - indx=0 - ios=0 - char8='' - lcoord=-1 - match=.false. - do while(.not.match .and. ios==0) - read(nop,117,iostat=ios) char8,nstep,rday,lcoord,dens, - & bmin,bmax - match=(trim(cfld)==trim(char8) .and. lcoord==coord) - indx=indx+1 - end do - close(nop) - - if (.not.match) then - indx=-1 - endif - - 117 format (a8,' = ',i11,f11.2,i3,f7.3,1p2e16.7) - end subroutine daily_index_from_header - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - - - - - INTEGER FUNCTION GET_NPAD(IDM,JDM) - IMPLICIT NONE - INTEGER, INTENT(IN) :: IDM,JDM - GET_NPAD = 4096 - MOD(IDM*JDM,4096) - GET_NPAD = mod(GET_NPAD,4096) - END FUNCTION - end module mod_raw_io diff --git a/assim/enkf_cf-system2_old/EnKF/nfw.F90 b/assim/enkf_cf-system2_old/EnKF/nfw.F90 deleted file mode 100755 index 8749ed39..00000000 --- a/assim/enkf_cf-system2_old/EnKF/nfw.F90 +++ /dev/null @@ -1,734 +0,0 @@ -! -! File: nfw.f90 -! -! Author: Pavel Sakov, CSIRO Marine Research -! -! Created: 17 March 2005 -! -! Purpose: Contains wrappers to netcdf functions, mainly for easier -! error handling. -! -! Description: -! -! Each subroutine in nfw.f90 is a simple wrapper of a similar -! function in the NetCDF Fortran interface. The rules of use are -! pretty simple: for a given NetCDF Fortran function, replace -! prefix "nf_" by "nfw_" and add the NetCDF file name as the -! first argument. -! -! Here is the current list of subroutines in nfw_mod: -! -! nfw_create(fname, mode, ncid) -! nfw_open(fname, mode, ncid) -! nfw_enddef(fname, ncid) -! nfw_close(fname, ncid) -! nfw_inq_unlimdim(fname, ncid, unlimdimid) -! nfw_inq_dimid(fname, ncid, name, dimid) -! nfw_inq_dimlen(fname, ncid, dimid, length) -! nfw_def_dim(fname, ncid, name, length, dimid) -! nfw_def_var(fname, ncid, name, type, ndims, dimids, varid) -! nfw_inq_varid(fname, ncid, name, varid) -! nfw_inq_varname(fname, ncid, varid, name) -! nfw_inq_varndims(fname, ncid, varid, ndims) -! nfw_inq_vardimid(fname, ncid, varid, dimids) -! nfw_rename_var(fname, ncid, oldname, newname) -! nfw_put_var_int(fname, ncid, varid, v) -! nfw_put_var_double(fname, ncid, varid, v) -! nfw_put_var_real(fname, ncid, varid, v) -! nfw_get_var_int(fname, ncid, varid, v) -! nfw_get_var_double(fname, ncid, varid, v) -! nfw_put_vara_int(fname, ncid, varid, start, length, v) -! nfw_put_vara_double(fname, ncid, varid, start, length, v) -! nfw_get_vara_int(fname, ncid, varid, start, length, v) -! nfw_get_vara_double(fname, ncid, varid, start, length, v) -! nfw_get_att_int(fname, ncid, varid, attname, v) -! nfw_get_att_real(fname, ncid, varid, attname, v) -! nfw_get_att_double(fname, ncid, varid, attname, v) -! nfw_put_att_text(fname, ncid, varid, attname, length, text) -! nfw_put_att_int(fname, ncid, varid, attname, type, length, v) -! nfw_put_att_real(fname, ncid, varid, attname, type, length, v) -! nfw_put_att_double(fname, ncid, varid, attname, type, length, v) -! -! Derived procedures: -! -! nfw_get_var_double_firstrecord(fname, ncid, varid, v) -! nfw_var_exists(ncid, name) -! nfw_dim_exists(ncid, name) -! Modifications: -! -! 29/04/2008 PS: added nfw_rename_var(fname, ncid, oldname, newname) -! 21/10/2009 PS: added nfw_var_exists(ncid, name) -! 22/10/2009 PS: added nfw_put_att_double(fname, ncid, varid, attname, type, -! length, v) -! 06/11/2009 PS: added nfw_dim_exists(ncid, name) -! nfw_put_att_real(fname, ncid, varid, attname, type, length, v) -! nfw_get_att_real(fname, ncid, varid, attname, v) - -module nfw_mod - implicit none - include 'netcdf.inc' - - character(*), private, parameter :: nfw_version = "0.03" - integer, private, parameter :: logunit = 6 - character(*), private, parameter :: errprefix = "nfw: error: " - private quit1, quit2, quit3 - -contains - -#if defined(F90_NOFLUSH) - subroutine flush(dummy) - integer, intent(in) :: dummy - end subroutine flush -#endif - - ! Common exit point -- for the sake of debugging - subroutine quit - stop - end subroutine quit - - subroutine quit1(fname, procname, status) - character*(*), intent(in) :: fname - character*(*), intent(in) :: procname - integer, intent(in) :: status - - write(logunit, *) - write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): ',& - nf_strerror(status) - call flush(logunit) - call quit - end subroutine quit1 - - subroutine quit2(fname, procname, name, status) - character*(*), intent(in) :: fname - character*(*), intent(in) :: procname - character*(*), intent(in) :: name - integer, intent(in) :: status - - write(logunit, *) - write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): "',& - trim(name), '": ', nf_strerror(status) - call flush(logunit) - call quit - end subroutine quit2 - - subroutine quit3(fname, procname, name1, name2, status) - character*(*), intent(in) :: fname - character*(*), intent(in) :: procname - character*(*), intent(in) :: name1 - character*(*), intent(in) :: name2 - integer, intent(in) :: status - - write(logunit, *) - write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): "',& - trim(name1), '": "', trim(name2), '": ', nf_strerror(status) - call flush(logunit) - call quit - end subroutine quit3 - - subroutine nfw_create(fname, mode, ncid) - character*(*), intent(in) :: fname - integer, intent(in) :: mode - integer, intent(out) :: ncid - - integer :: status - - status = nf_create(trim(fname), mode, ncid) - if (status /= 0) call quit1(fname, 'nf_create', status) - end subroutine nfw_create - - subroutine nfw_open(fname, mode, ncid) - character*(*), intent(in) :: fname - integer, intent(in) :: mode - integer, intent(out) :: ncid - - integer :: status - - status = nf_open(trim(fname), mode, ncid) - if (status /= 0) call quit1(fname, 'nf_open', status) - end subroutine nfw_open - - subroutine nfw_enddef(fname, ncid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - - integer :: status - - status = nf_enddef(ncid) - if (status /= 0) call quit1(fname, 'nf_enddef', status) - end subroutine nfw_enddef - - subroutine nfw_redef(fname, ncid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - - integer :: status - - status = nf_redef(ncid) - if (status /= 0) call quit1(fname, 'nf_redef', status) - end subroutine nfw_redef - - subroutine nfw_close(fname, ncid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - - integer :: status - - status = nf_close(ncid) - if (status /= 0) call quit1(fname, 'nf_close', status) - end subroutine nfw_close - - subroutine nfw_inq_unlimdim(fname, ncid, unlimdimid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(out) :: unlimdimid - - integer :: status - - status = nf_inq_unlimdim(ncid, unlimdimid) - if (status /= 0) call quit1(fname, 'nf_inq_unlimdimid', status) - end subroutine nfw_inq_unlimdim - - subroutine nfw_inq_dimid(fname, ncid, name, dimid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - character*(*), intent(in) :: name - integer, intent(out) :: dimid - - integer :: status - - status = nf_inq_dimid(ncid, trim(name), dimid) - if (status /= 0) call quit2(fname, 'nf_inq_dimid', name, status) - end subroutine nfw_inq_dimid - - subroutine nfw_inq_dimlen(fname, ncid, dimid, length) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: dimid - integer, intent(out) :: length - - integer :: status - - status = nf_inq_dimlen(ncid, dimid, length) - if (status /= 0) call quit1(fname, 'nf_inq_dimlen', status) - end subroutine nfw_inq_dimlen - - subroutine nfw_def_dim(fname, ncid, name, length, dimid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - character*(*), intent(in) :: name - integer, intent(in) :: length - integer, intent(out) :: dimid - - integer :: status - - status = nf_def_dim(ncid, name, length, dimid) - if (status /= 0) call quit2(fname, 'nf_def_dim', name, status) - end subroutine nfw_def_dim - - subroutine nfw_def_var(fname, ncid, name, type, ndims, dimids, varid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - character*(*), intent(in) :: name - integer, intent(in) :: type - integer, intent(in) :: ndims - integer, intent(in) :: dimids(*) - integer, intent(out) :: varid - - integer :: status - - status = nf_def_var(ncid, name, type, ndims, dimids, varid) - if (status /= 0) call quit2(fname, 'nf_def_var', name, status) - end subroutine nfw_def_var - - subroutine nfw_inq_varid(fname, ncid, name, varid) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - character*(*), intent(in) :: name - integer, intent(out) :: varid - - integer :: status - - status = nf_inq_varid(ncid, trim(name), varid) - if (status /= 0) call quit2(fname, 'nf_inq_varid', name, status) - end subroutine nfw_inq_varid - - subroutine nfw_inq_varname(fname, ncid, varid, name) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(out) :: name - - integer :: status - - status = nf_inq_varname(ncid, varid, name) - if (status /= 0) call quit1(fname, 'nf_inq_varname', status) - end subroutine nfw_inq_varname - - subroutine nfw_inq_varndims(fname, ncid, varid, ndims) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(out) :: ndims - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_inq_varndims(ncid, varid, ndims) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_inq_varndims', name, status) - end if - end subroutine nfw_inq_varndims - - subroutine nfw_inq_vardimid(fname, ncid, varid, dimids) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(out) :: dimids(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_inq_vardimid(ncid, varid, dimids) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_inq_vardimid', name, status) - end if - end subroutine nfw_inq_vardimid - - subroutine nfw_rename_var(fname, ncid, oldname, newname) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - character*(*), intent(in) :: oldname - character*(*), intent(in) :: newname - - integer :: varid - integer :: status - - call nfw_inq_varid(fname, ncid, oldname, varid) - status = nf_rename_var(ncid, varid, newname) - if (status /= 0) then - call quit2(fname, 'nf_rename_var', oldname, status) - end if - end subroutine nfw_rename_var - - subroutine nfw_put_var_int(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_put_var_int(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_put_var_double', name, status) - end if - end subroutine nfw_put_var_int - - subroutine nfw_put_var_double(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - real(8), intent(in) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_put_var_double(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_put_var_double', name, status) - end if - end subroutine nfw_put_var_double - - subroutine nfw_put_var_real(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - real(4), intent(in) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_put_var_real(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_put_var_real', name, status) - end if - end subroutine nfw_put_var_real - - subroutine nfw_get_var_int(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_var_int(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_var_int', name, status) - end if - end subroutine nfw_get_var_int - - subroutine nfw_get_var_double(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - real(8), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_var_double(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_var_double', name, status) - end if - end subroutine nfw_get_var_double - - subroutine nfw_get_var_real(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - real(4), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_var_real(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_var_real', name, status) - end if - end subroutine nfw_get_var_real - - - subroutine nfw_get_var_text(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character, intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_var_text(ncid, varid, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_var_int', name, status) - end if - end subroutine nfw_get_var_text - - subroutine nfw_put_vara_int(fname, ncid, varid, start, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: start(*) - integer, intent(in) :: length(*) - integer, intent(in) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_put_vara_int(ncid, varid, start, length, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_put_vara_int', name, status) - end if - end subroutine nfw_put_vara_int - - subroutine nfw_put_vara_double(fname, ncid, varid, start, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: start(*) - integer, intent(in) :: length(*) - real(8), intent(in) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_put_vara_double(ncid, varid, start, length, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_put_vara_double', name, status) - end if - end subroutine nfw_put_vara_double - - subroutine nfw_get_vara_int(fname, ncid, varid, start, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: start(*) - integer, intent(in) :: length(*) - integer, intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_vara_int(ncid, varid, start, length, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_vara_int', name, status) - end if - end subroutine nfw_get_vara_int - - subroutine nfw_get_vara_double(fname, ncid, varid, start, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: start(*) - integer, intent(in) :: length(*) - real(8), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_vara_double(ncid, varid, start, length, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_vara_double', name, status) - end if - end subroutine nfw_get_vara_double - - subroutine nfw_get_vara_real(fname, ncid, varid, start, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: start(*) - integer, intent(in) :: length(*) - real(4), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: name - integer :: status - - status = nf_get_vara_real(ncid, varid, start, length, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_vara_real', name, status) - end if - end subroutine nfw_get_vara_real - - - subroutine nfw_get_att_int(fname, ncid, varid, attname, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - integer, intent(out) :: v(*) - - character*(NF_MAX_NAME) :: varname - integer :: status - - status = nf_get_att_int(ncid, varid, attname, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_get_att_int', varname, attname, status) - end if - end subroutine nfw_get_att_int - - subroutine nfw_get_att_real(fname, ncid, varid, attname, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - real(4), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: varname - integer :: status - - status = nf_get_att_real(ncid, varid, attname, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_get_att_real', varname, attname, status) - end if - end subroutine nfw_get_att_real - - subroutine nfw_get_att_double(fname, ncid, varid, attname, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - real(8), intent(out) :: v(*) - - character*(NF_MAX_NAME) :: varname - integer :: status - - status = nf_get_att_double(ncid, varid, attname, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_get_att_double', varname, attname, status) - end if - end subroutine nfw_get_att_double - - subroutine nfw_put_att_text(fname, ncid, varid, attname, length, text) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - integer, intent(in) :: length - character*(*), intent(in) :: text - - integer :: status - character*(NF_MAX_NAME) :: varname - - status = nf_put_att_text(ncid, varid, attname, length, trim(text)) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_put_att_text', varname, attname, status) - end if - end subroutine nfw_put_att_text - - subroutine nfw_put_att_int(fname, ncid, varid, attname, type, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - integer, intent(in) :: type - integer, intent(in) :: length - integer, intent(in) :: v(*) - - integer :: status - character*(NF_MAX_NAME) :: varname - - status = nf_put_att_int(ncid, varid, attname, type, length, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_put_att_int', varname, attname, status) - end if - end subroutine nfw_put_att_int - - subroutine nfw_put_att_real(fname, ncid, varid, attname, type, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - integer, intent(in) :: type - integer, intent(in) :: length - real(4), intent(in) :: v(*) - - integer :: status - character*(NF_MAX_NAME) :: varname - - status = nf_put_att_real(ncid, varid, attname, type, length, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_put_att_real', varname, attname, status) - end if - end subroutine nfw_put_att_real - - subroutine nfw_put_att_double(fname, ncid, varid, attname, type, length, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - character*(*), intent(in) :: attname - integer, intent(in) :: type - integer, intent(in) :: length - real(8), intent(in) :: v(*) - - integer :: status - character*(NF_MAX_NAME) :: varname - - status = nf_put_att_double(ncid, varid, attname, type, length, v) - if (status /= 0) then - if (varid /= nf_global) then - call nfw_inq_varname(fname, ncid, varid, varname) - else - varname = 'NF_GLOBAL' - end if - call quit3(fname, 'nf_put_att_double', varname, attname, status) - end if - end subroutine nfw_put_att_double - -! Derived subroutines - - ! Reads the first record only - subroutine nfw_get_var_double_firstrecord(fname, ncid, varid, v) - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - real(8), intent(out) :: v(*) - - integer :: ndims - integer :: unlimdimid - integer :: dimids(NF_MAX_VAR_DIMS) - integer :: dimlen(NF_MAX_VAR_DIMS) - integer :: dstart(NF_MAX_VAR_DIMS) - integer :: i - character*(NF_MAX_NAME) :: name - integer :: status - - call nfw_inq_varndims(fname, ncid, varid, ndims) - call nfw_inq_vardimid(fname, ncid, varid, dimids) - call nfw_inq_unlimdim(fname, ncid, unlimdimid) - - do i = 1, ndims - call nfw_inq_dimlen(fname, ncid, dimids(i), dimlen(i)) - dstart(i) = 1 - end do - - ! check size of v - if (dimids(ndims) == unlimdimid) then - dimlen(ndims) = 1 ! 1 record only - end if - - status = nf_get_vara_double(ncid, varid, dstart, dimlen, v) - if (status /= 0) then - call nfw_inq_varname(fname, ncid, varid, name) - call quit2(fname, 'nf_get_vara_double', name, status) - end if - end subroutine nfw_get_var_double_firstrecord - - logical function nfw_var_exists(ncid, name) - integer, intent(in) :: ncid - character*(*), intent(in) :: name - - integer :: varid - integer :: status - - status = nf_inq_varid(ncid, trim(name), varid) - nfw_var_exists = (status == 0) - end function nfw_var_exists - - logical function nfw_dim_exists(ncid, name) - integer, intent(in) :: ncid - character*(*), intent(in) :: name - - integer :: dimid - integer :: status - - status = nf_inq_dimid(ncid, trim(name), dimid) - nfw_dim_exists = (status == 0) - end function nfw_dim_exists - -end module nfw_mod diff --git a/assim/enkf_cf-system2_old/EnKF/order.c b/assim/enkf_cf-system2_old/EnKF/order.c deleted file mode 100755 index 9956fbf4..00000000 --- a/assim/enkf_cf-system2_old/EnKF/order.c +++ /dev/null @@ -1,110 +0,0 @@ -/* File: order.c - * - * Created: 2 Mar 2008 - * - * Last modified: 2 Mar 2008 - * Author: Pavel Sakov - * NERSC - * - * Purpose: Put indices of an array of double in an order of increasing - * value. - * - * Description: Given a double array x[n], sort its subset specified by an - * integer array of indices good[ngood] and return the indices - * of sorted elements in the integer array inorder[ngood]. - * - * It is assumed that good[ngood] stores the "fortran" indices - * (from 1 to N rather than from 0 to N - 1). - * - * Modifications: none - */ - -#include -#include -#include -#include -#include "cfortran.h" - -typedef struct { - int index; - double v; -} indexedvalue; - -static int comp(const void* p1, const void* p2) -{ - indexedvalue* v1 = (indexedvalue*) p1; - indexedvalue* v2 = (indexedvalue*) p2; - - if (v1->v > v2->v) - return 1; - else if (v1->v < v2->v) - return -1; - return 0; -} - -/** Sorts a specified subset within an array of double according to values. - * - * Given a double array x[n], sorts its subset specified by an integer array - * good[ngood] and returns the indices of sorted elements in the preallocated - * integer array inorder[ngood]. - * - * It is assumed that good[ngood] stores the "fortran" indices (from 1 to N - * rather than from 0 to N - 1). - * - * @param pn Number of elements in the data array - * @param x Data array - * @param pngood Number of elements in the data array to be sorted - * @param good Indices of the elements in the data array to be sorted - * @param inorder Output array of size of `ngood' such that the corresponding - * elements of the data array are in increasing order - */ -void order(double pn[], double x[], double pngood[], int good[], int inorder[]) -{ - int n = (int) pn[0]; - int ngood = (int) pngood[0]; - indexedvalue* iv = NULL; - int i; - - if (n <= 0) { - for (i = 0; i < ngood; ++i) - inorder[i] = -1; - return; - } - - iv = malloc(n * sizeof(indexedvalue)); - if (n < ngood) { - fprintf(stderr, "ERROR: order.c: order(): size of the data = %d is less than the requested size of the sorted array %d\n", n, ngood); - exit(1); - } - - /* - * a bit of quality control - */ - for (i = 0; i < ngood; ++i) { - double xx; - - if (good[i] < 1 || good[i] > n) { - fprintf(stderr, "ERROR: order.c: order(): good[%d] = %d, n = %d\n", i, good[i], n); - exit(1); - } - xx = x[good[i] - 1]; - if (isnan(xx) || fabs(xx) > 1.0e+10 || xx == -999.0) { - fprintf(stderr, "ERROR: order.c: order(): x[%d] = %.15g\n", good[i] - 1, xx); - exit(1); - } - } - - for (i = 0; i < ngood; ++i) { - iv[i].index = good[i]; - iv[i].v = x[good[i] - 1]; - } - - qsort(iv, ngood, sizeof(indexedvalue), comp); - - for (i = 0; i < ngood; ++i) - inorder[i] = iv[i].index; - - free(iv); -} - -FCALLSCSUB5(order, ORDER, order, PDOUBLE, PDOUBLE, PDOUBLE, PINT, PINT) diff --git a/assim/enkf_cf-system2_old/EnKF/qmpi.F90 b/assim/enkf_cf-system2_old/EnKF/qmpi.F90 deleted file mode 100755 index f6236878..00000000 --- a/assim/enkf_cf-system2_old/EnKF/qmpi.F90 +++ /dev/null @@ -1,2072 +0,0 @@ -#if defined(QMPI) -module qmpi -! -! A module defining a minimalist interface to a subset of MPI. -! The first five primitives can in theory be used to parallelize -! any program. The module hides type specification, communicators, -! explicit error handling, the need to give explicit buffer size etc. -! Also provided are a few interfaces for often used broadcast and -! reduction operations -! -! © Helge Avlesen , para//ab -! -! primitives: (optional arguments in brackets) -! -! subroutine start_mpi() -! starts the mpi subsystem. all processesors are assigned a number (myid). -! the number of processors is numproc. -! subroutine stop_mpi() -! stops the mpi subsystem -! subroutine barrier([label]) -! syncronization point for all processors. optionally prints a label on -! the master processor (0). -! subroutine send(data, target [,tag]) -! send object data to processor number target, tag is an optional integer -! that defaults to 0. (if multiple messages are exchanged between a -! pair of processors, a unique tag must be used for each exhange) -! subroutine receive(data, source [,tag]) -! get object data from processor source, tag is optional and as for send -! MPI will fail if the size of the object received is different from what -! was sent. -! -! The rest of the routines are included for convenience, they can be -! also be implemented using the above subroutines. -! -! subroutine broadcast(data [,root]) -! broadcast data (any type) from processor root (default=0) to all -! other processors. -! subroutine mbroadcast(data [,data2,data3,data4,data5,data6] [,root]) -! broadcast up to 6 scalar variables of the same type, to all processors -! from processor root (default=0) -! subroutine reduce(type, data [,data2,data3,data4,data5,data6] [,root] ) -! reduce the scalar data, optionally also data2-data6, return result -! on all processes. the operation can currently be of type 'sum', 'mul', -! 'min' or 'max' i.e. a sum or a product. data-data6 must be of the -! same type. if integer root is present, only return result on that -! processor (faster) -! -! Example: a program that sends a real from processor 0 to processor 1 -! use qmpi -! real data -! call start_mpi -! data=myid -! if(myid==0) call send(data, 1) -! if(myid==1) then -! call receive(data, 0) -! print *,'hello, I am',myid,'got ',data,'from process 0' -! end if -! call stop_mpi -! end -! -! More advanced usage example: to send a derived type from 0 to 1; -! pack it in a string (could be packed into any array), send, receive, unpack. -! -! type(any_type) var1 -! character, allocatable :: buffer(:) -! ... -! N=size(transfer(var1,(/'x'/)))) !! compute size of type once -! allocate(buffer(N)) -! if(myid==0)then -! buffer = transfer(var1,buffer) -! call send(buffer,1) -! end if -! if(myid==1)then -! call receive(buffer,0) -! var1 = transfer(buffer,var1) -! end if -! ... -! -#warning "COMPILING WITH QMPI CODE" - include 'mpif.h' - integer, public :: qmpi_proc_num, qmpi_num_proc, ierr, errorcode, mpistatus(mpi_status_size) - logical, public :: master=.false., slave=.false. - -! some kinds. could use selected_real_kind(..) for this instead of hard coding - integer, parameter :: dp=8, sp=4, long=8, short=2 - - interface send - module procedure & - qmpi_send_real4, & - qmpi_send_real4_1d, & - qmpi_send_real4_2d, & - qmpi_send_real4_3d, & - qmpi_send_real4_4d, & - qmpi_send_real8, & - qmpi_send_real8_1d, & - qmpi_send_real8_2d, & - qmpi_send_real8_3d, & - qmpi_send_real8_4d, & - qmpi_send_integer4, & - qmpi_send_integer4_1d, & - qmpi_send_integer4_2d, & - qmpi_send_integer4_3d, & - qmpi_send_integer4_4d, & - qmpi_send_integer8, & - qmpi_send_integer8_1d, & - qmpi_send_integer8_2d, & - qmpi_send_integer8_3d, & - qmpi_send_integer8_4d, & - qmpi_send_string, & - qmpi_send_character_1d,& - qmpi_send_logical - end interface - - interface receive - module procedure & - qmpi_recv_real4, & - qmpi_recv_real4_1d, & - qmpi_recv_real4_2d, & - qmpi_recv_real4_3d, & - qmpi_recv_real4_4d, & - qmpi_recv_real8, & - qmpi_recv_real8_1d, & - qmpi_recv_real8_2d, & - qmpi_recv_real8_3d, & - qmpi_recv_real8_4d, & - qmpi_recv_integer4, & - qmpi_recv_integer4_1d, & - qmpi_recv_integer4_2d, & - qmpi_recv_integer4_3d, & - qmpi_recv_integer4_4d, & - qmpi_recv_integer8, & - qmpi_recv_integer8_1d, & - qmpi_recv_integer8_2d, & - qmpi_recv_integer8_3d, & - qmpi_recv_integer8_4d, & - qmpi_recv_string, & - qmpi_recv_character_1d,& - qmpi_recv_logical - end interface - - interface reduce - module procedure & - qmpi_integer_reduction, & - qmpi_integer8_reduction,& - qmpi_real_reduction, & - qmpi_real8_reduction - end interface - - interface broadcast - module procedure & - qmpi_broadcast_logical, & - qmpi_broadcast_string, & - qmpi_broadcast_stringarr,& - qmpi_broadcast_integer4, & - qmpi_broadcast_integer4_array1d, & - qmpi_broadcast_integer4_array2d, & - qmpi_broadcast_integer8, & - qmpi_broadcast_integer8_array1d, & - qmpi_broadcast_integer8_array2d, & - qmpi_broadcast_real4, & - qmpi_broadcast_real4_array1d, & - qmpi_broadcast_real4_array2d, & - qmpi_broadcast_real4_array3d, & - qmpi_broadcast_real4_array4d, & - qmpi_broadcast_real8, & - qmpi_broadcast_real8_array1d, & - qmpi_broadcast_real8_array2d, & - qmpi_broadcast_real8_array3d, & - qmpi_broadcast_real8_array4d - end interface - - interface mbroadcast - module procedure & - qmpi_broadcast_logicals, & - qmpi_broadcast_real4s, & - qmpi_broadcast_real8s, & - qmpi_broadcast_integer4s, & - qmpi_broadcast_integer8s - end interface - -contains - - subroutine start_mpi() -! -! initialize the core MPI subsystem -! this routine should be called as the first statement in the program. -! MPI does not specify what happen before MPI_init and after mpi_finalize -! - implicit none - - call mpi_init(ierr) - call mpi_comm_size(mpi_comm_world, qmpi_num_proc, ierr) - call mpi_comm_rank(mpi_comm_world, qmpi_proc_num, ierr) - - master=.false. - if(qmpi_proc_num==0) master=.true. - if(qmpi_proc_num>0) slave=.true. -print*,'Inne i start_mpi: qmpi_proc_num =',qmpi_proc_num,' master =',master - - if(master) then - write(*,'(a,i0,a)') 'MPI started with ',qmpi_num_proc,' processors' - end if - end subroutine start_mpi - - subroutine stop_mpi() - implicit none - call mpi_finalize(ierr) - stop - end subroutine stop_mpi - - subroutine barrier(label) -! makes all processes sync at this point, optionally print a label - implicit none - character(*), optional :: label - call mpi_barrier(mpi_comm_world, ierr) - if(master.and.present(label)) print *,'---barrier---',label,'---------' - end subroutine barrier - - subroutine qmpi_send_logical(data, target, tag) - implicit none - logical data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_send(data, counter, mpi_logical, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_logical count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_logical - - subroutine qmpi_send_string(data, target, tag) - implicit none - character(*) data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=len(data) - call mpi_send(data, counter, mpi_character, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_string count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_string - - subroutine qmpi_send_character_1d(data, target, tag) - implicit none - character data(:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_send(data, counter, mpi_character, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_character_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_character_1d - - subroutine qmpi_recv_character_1d(data, target, tag) - implicit none - character data(:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_recv(data, counter, mpi_character, target, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_character_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_character_1d - - subroutine qmpi_send_integer4(data, target, tag) - implicit none - integer(sp) data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer4 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer4 - - subroutine qmpi_send_integer4_1d(data, target, tag) - implicit none - integer(sp) data(:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer4_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer4_1d - - subroutine qmpi_send_integer4_2d(data, target, tag) - implicit none - integer(sp) data(:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer4_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer4_2d - - subroutine qmpi_send_integer4_3d(data, target, tag) - implicit none - integer(sp) data(:,:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer4_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer4_3d - - subroutine qmpi_send_integer4_4d(data, target, tag) - implicit none - integer(sp) data(:,:,:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer4_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer4_4d - - subroutine qmpi_send_integer8(data, target, tag) - implicit none - integer(long) data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer8 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer8 - - subroutine qmpi_send_integer8_1d(data, target, tag) - implicit none - integer(long) data(:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer8_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer8_1d - - subroutine qmpi_send_integer8_2d(data, target, tag) - implicit none - integer(long) data(:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer8_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer8_2d - - subroutine qmpi_send_integer8_3d(data, target, tag) - implicit none - integer(8) data(:,:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer8_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer8_3d - - subroutine qmpi_send_integer8_4d(data, target, tag) - implicit none - integer(8) data(:,:,:,:) - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_integer8_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_integer8_4d - - subroutine qmpi_send_real4(data, target, tag) - implicit none - real(sp) data - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_real4 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real4 - - subroutine qmpi_send_real8(data, target, tag) - implicit none - real(dp) data - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_real8 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real8 - - subroutine qmpi_send_real4_1d(data, target, tag) - implicit none - real(sp) data(:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_real4_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real4_1d - - subroutine qmpi_send_real8_1d(data, target, tag) - implicit none - real(dp) data(:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr) - if(ierr.ne.0)then - print *,'error send_real8_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real8_1d - - subroutine qmpi_send_real4_2d(data, target, tag) - implicit none - real(sp) data(:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - - call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real4_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real4_2d - - subroutine qmpi_send_real8_2d(data, target, tag) - implicit none - real(dp) data(:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - - call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real8_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real8_2d - - subroutine qmpi_send_real4_3d(data, target, tag) - implicit none - real(sp) data(:,:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - - call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real4_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real4_3d - - subroutine qmpi_send_real8_3d(data, target, tag) - implicit none - real(dp) data(:,:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - - call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real8_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real8_3d - - subroutine qmpi_send_real4_4d(data, target, tag) - implicit none - real(sp) data(:,:,:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - - call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real4_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real4_4d - - subroutine qmpi_send_real8_4d(data, target, tag) - implicit none - real(dp) data(:,:,:,:) - integer target - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - - call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr) - - if(ierr.ne.0)then - print *,'error send_real8_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_send_real8_4d - - subroutine qmpi_recv_integer4(data, source, tag) - implicit none - integer(sp) data - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer4_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer4 - - subroutine qmpi_recv_integer4_1d(data, source, tag) - implicit none - integer(sp) data(:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer4_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer4_1d - - subroutine qmpi_recv_integer4_2d(data, source, tag) - implicit none - integer(sp) data(:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer4_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer4_2d - - subroutine qmpi_recv_integer4_3d(data, source, tag) - implicit none - integer(sp) data(:,:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer4_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer4_3d - - subroutine qmpi_recv_integer4_4d(data, source, tag) - implicit none - integer(sp) data(:,:,:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer4_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer4_4d - - subroutine qmpi_recv_integer8(data, source, tag) - implicit none - integer(long) data - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer8 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer8 - - subroutine qmpi_recv_integer8_1d(data, source, tag) - implicit none - integer(long) data(:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer8_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer8_1d - - subroutine qmpi_recv_integer8_2d(data, source, tag) - implicit none - integer(long) data(:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer8_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer8_2d - - subroutine qmpi_recv_integer8_3d(data, source, tag) - implicit none - integer(8) data(:,:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer8_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer8_3d - - subroutine qmpi_recv_integer8_4d(data, source, tag) - implicit none - integer(8) data(:,:,:,:) - integer source, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_integer8_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_integer8_4d - - subroutine qmpi_recv_real4(data, source, tag) - implicit none - real(sp) data - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_real4 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real4 - - subroutine qmpi_recv_real8(data, source, tag) - implicit none - real(dp) data - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_real8 count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real8 - - subroutine qmpi_recv_real4_1d(data, source, tag) - implicit none - real(sp) data(:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_real4_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real4_1d - - subroutine qmpi_recv_real8_1d(data, source, tag) - implicit none - real(dp) data(:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data) - call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_real8_1d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real8_1d - - subroutine qmpi_recv_real4_2d(data, source, tag) - implicit none - real(sp) data(:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - - call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real4_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real4_2d - - subroutine qmpi_recv_real8_2d(data, source, tag) - implicit none - real(dp) data(:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2) - - call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real8_2d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real8_2d - - subroutine qmpi_recv_real4_3d(data, source, tag) - implicit none - real(sp) data(:,:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - - call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real4_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real4_3d - - subroutine qmpi_recv_real8_3d(data, source, tag) - implicit none - real(dp) data(:,:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3) - - call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real8_3d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real8_3d - - subroutine qmpi_recv_real4_4d(data, source, tag) - implicit none - real(sp) data(:,:,:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - - call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real4_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real4_4d - - subroutine qmpi_recv_real8_4d(data, source, tag) - implicit none - real(dp) data(:,:,:,:) - integer source - integer, optional :: tag - integer counter, given_tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - - call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr) - - if(ierr.ne.0)then - print *,'error recv_real8_4d count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_real8_4d - - subroutine qmpi_recv_logical(data, target, tag) - implicit none - logical data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=1 - call mpi_recv(data, counter, mpi_logical, target, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_logical count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_logical - - subroutine qmpi_recv_string(data, target, tag) - implicit none - character(*) data - integer target, counter, given_tag - integer, optional :: tag - - given_tag=0 - if(present(tag)) given_tag=tag - counter=len(data) - call mpi_recv(data, counter, mpi_character, target, given_tag, mpi_comm_world, mpistatus, ierr) - if(ierr.ne.0)then - print *,'error recv_string count=',counter,'tag=',given_tag - stop - end if - end subroutine qmpi_recv_string - - subroutine qmpi_broadcast_string(string,root) -! -! send string out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - character(len=*) string - integer, optional :: root - integer counter,boss - - counter=len(string) - - boss=0 - if(present(root)) then - boss=root - end if - - call mpi_bcast(string , counter, mpi_character, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_string - - subroutine qmpi_broadcast_stringarr(data,root) - implicit none - character(len=*) data(:) - integer, optional :: root - integer counter, boss - - counter=len(data(1))*size(data) - - boss=0 - if(present(root)) then - boss=root - end if - - call mpi_bcast(data, counter, mpi_character, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_stringarr - - subroutine qmpi_broadcast_real4(data,root) - implicit none - real(4) data - integer, optional :: root - integer counter,boss - - counter=1 - boss=0 - if(present(root)) boss=root - call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world, ierr) - end subroutine qmpi_broadcast_real4 - - subroutine qmpi_broadcast_real8(data,root) - implicit none - real(8) data - integer, optional :: root - integer counter,boss - - counter=1 - boss=0 - if(present(root)) boss=root - call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world, ierr) - end subroutine qmpi_broadcast_real8 - - subroutine qmpi_broadcast_integer4(data,root) - implicit none - integer(4) data - integer, optional :: root - integer counter,boss - - counter=1 - boss=0 - if(present(root)) boss=root - call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world, ierr) - end subroutine qmpi_broadcast_integer4 - - subroutine qmpi_broadcast_integer8(data,root) - implicit none - integer(8) data - integer, optional :: root - integer counter,boss - - counter=1 - boss=0 - if(present(root)) boss=root - call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world, ierr) - end subroutine qmpi_broadcast_integer8 - - subroutine qmpi_broadcast_logical(data, root) - implicit none - logical data - integer, optional :: root - integer counter,boss - - counter=1 - boss=0 - if(present(root)) boss=root - call mpi_bcast(data , counter, mpi_logical, boss, mpi_comm_world, ierr) - end subroutine qmpi_broadcast_logical - - - subroutine qmpi_broadcast_integer4_array1d(data,root) - implicit none - integer(sp) data(:) - integer, optional :: root - integer counter,boss - - counter=size(data) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_integer4_array1d - - subroutine qmpi_broadcast_integer8_array1d(data,root) - implicit none - integer(long) data(:) - integer, optional :: root - integer counter,boss - - counter=size(data) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_integer8_array1d - - subroutine qmpi_broadcast_integer4_array2d(data,root) - implicit none - integer(sp) data(:,:) - integer, optional :: root - integer counter,boss - - counter=size(data,1)*size(data,2) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_integer4_array2d - - subroutine qmpi_broadcast_integer8_array2d(data,root) - implicit none - integer(long) data(:,:) - integer, optional :: root - integer counter,boss - - counter=size(data,1)*size(data,2) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_integer8_array2d - - subroutine qmpi_broadcast_real4_array1d(data,root) - implicit none - real(sp) data(:) - integer, optional :: root - integer counter, boss - - counter=size(data) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real4_array1d - - subroutine qmpi_broadcast_real8_array1d(data,root) - implicit none - real(dp) data(:) - integer, optional :: root - integer counter, boss - - counter=size(data) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real8_array1d - - subroutine qmpi_broadcast_real4_array2d(data,root) - implicit none - real(sp) data(:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data, counter, mpi_real, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real4_array2d - - subroutine qmpi_broadcast_real8_array2d(data,root) - implicit none - real(dp) data(:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data, counter, mpi_double_precision, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real8_array2d - - subroutine qmpi_broadcast_real4_array3d(data,root) - implicit none - real(sp) data(:,:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2)*size(data,3) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real4_array3d - - subroutine qmpi_broadcast_real8_array3d(data,root) - implicit none - real(dp) data(:,:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2)*size(data,3) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real8_array3d - - subroutine qmpi_broadcast_real4_array4d(data,root) - implicit none - real(sp) data(:,:,:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real4_array4d - - subroutine qmpi_broadcast_real8_array4d(data,root) - implicit none - real(dp) data(:,:,:,:) - integer, optional :: root - integer counter, boss - - counter=size(data,1)*size(data,2)*size(data,3)*size(data,4) - boss=0 - if(present(root)) then - boss=root - end if - call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world ,ierr) - end subroutine qmpi_broadcast_real8_array4d - - subroutine qmpi_broadcast_real4s(a,b,c,d,e,f,root) -! -! send a,b,c,d,e,f out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - real(sp) a - real(sp), optional :: b,c,d,e,f - integer, optional :: root - integer counter,boss - real(sp) rbuff(6) - - counter=0 ; boss=0 - if(present(root)) then - boss=root - end if -! if(present(a)) then - counter=counter+1 - rbuff(counter)=a -! end if - if(present(b)) then - counter=counter+1 - rbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=f - end if - - call mpi_bcast(rbuff , counter, mpi_real, boss, mpi_comm_world ,ierr) - - counter=1 - a=rbuff(counter) - if(present(b)) then - counter=counter+1 - b=rbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=rbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=rbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=rbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=rbuff(counter) - end if - end subroutine qmpi_broadcast_real4s - - subroutine qmpi_broadcast_real8s(a,b,c,d,e,f,root) -! -! send a,b,c,d,e,f out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - real(dp) a - real(dp), optional :: b,c,d,e,f - integer, optional :: root - integer counter,boss - real(kind=8) rbuff(6) - - boss=0 - if(present(root)) then - boss=root - end if - counter=1 - rbuff(counter)=a - if(present(b)) then - counter=counter+1 - rbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=f - end if - - call mpi_bcast(rbuff , counter, mpi_double_precision, boss, mpi_comm_world ,ierr) - - counter=1 - a=rbuff(counter) - if(present(b)) then - counter=counter+1 - b=rbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=rbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=rbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=rbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=rbuff(counter) - end if - end subroutine qmpi_broadcast_real8s - - subroutine qmpi_broadcast_logicals(a,b,c,d,e,f,root) -! -! send a,b,c,d,e,f out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - logical a - logical, optional :: b,c,d,e,f - integer, optional :: root - integer counter,boss - logical lbuff(6) - - boss=0 - if(present(root)) then - boss=root - end if - - counter=1 - lbuff(counter)=a - if(present(b)) then - counter=counter+1 - lbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - lbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - lbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - lbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - lbuff(counter)=f - end if - - call mpi_bcast(lbuff , counter, mpi_logical, boss, mpi_comm_world ,ierr) - - counter=1 - a=lbuff(counter) - - if(present(b)) then - counter=counter+1 - b=lbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=lbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=lbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=lbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=lbuff(counter) - end if - end subroutine qmpi_broadcast_logicals - - subroutine qmpi_broadcast_integer4s(a,b,c,d,e,f,root) -! -! send a,b,c,d,e,f out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - integer(sp) a - integer(sp), optional :: b,c,d,e,f,root - integer counter,boss - integer ibuff(6) - - boss=0 - if(present(root)) then - boss=root - end if - - counter=1 -! if(present(a)) then -! counter=counter+1 - ibuff(counter)=a -! end if - if(present(b)) then - counter=counter+1 - ibuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - ibuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - ibuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - ibuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - ibuff(counter)=f - end if - - call mpi_bcast(ibuff , counter, mpi_integer, boss, mpi_comm_world ,ierr) - - counter=1 - a=ibuff(counter) - - if(present(b)) then - counter=counter+1 - b=ibuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=ibuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=ibuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=ibuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=ibuff(counter) - end if - end subroutine qmpi_broadcast_integer4s - - subroutine qmpi_broadcast_integer8s(a,b,c,d,e,f,root) -! -! send a,b,c,d,e,f out to all processes. if not given -! process 0 will be used as the sender - root otherwise. -! - implicit none - integer(long) a - integer(long), optional :: b,c,d,e,f,root - integer counter,boss - integer ibuff(6) - - boss=0 - if(present(root)) then - boss=root - end if - - counter=1 -! if(present(a)) then -! counter=counter+1 - ibuff(counter)=a -! end if - if(present(b)) then - counter=counter+1 - ibuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - ibuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - ibuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - ibuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - ibuff(counter)=f - end if - - call mpi_bcast(ibuff , counter, mpi_integer8, boss, mpi_comm_world ,ierr) - - counter=1 - a=ibuff(counter) - - if(present(b)) then - counter=counter+1 - b=ibuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=ibuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=ibuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=ibuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=ibuff(counter) - end if - end subroutine qmpi_broadcast_integer8s - - subroutine qmpi_real_reduction(type,a,b,c,d,e,f,root) -! -! perform a reduction of 'type' on each of the given arguments a - f. -! if type is: -! 'sum': for each argument, return the sum of the argument over all processors -! 'mul': the product -! 'min': the minimum value -! 'max': the maximum value -! root is an optional argument, if given only return the result on that processor (reduce) -! the default is to return the result on all processors (allreduce) -! - implicit none - character(3) type - real(sp) a - real(sp), optional, intent(inout) :: b,c,d,e,f - integer, optional :: root - integer counter,boss - integer, parameter :: dp=8 - real(dp) rbuff(6),globrbuff(6) - - if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then - print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported' - stop - end if - - boss=0 - if(present(root)) boss=root - - globrbuff(:)=0.0 - counter=0 -! if(present(a)) then - counter=counter+1 - rbuff(counter)=real(a,dp) -! end if - if(present(b)) then - counter=counter+1 - rbuff(counter)=real(b,dp) - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=real(c,dp) - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=real(d,dp) - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=real(e,dp) - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=real(f,dp) - end if - - select case(type) - case('sum') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,mpi_comm_world,ierr) - end if - case('mul') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,mpi_comm_world,ierr) - end if - case('min') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,mpi_comm_world,ierr) - end if - case('max') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,mpi_comm_world,ierr) - end if - end select - - counter=0 -! if(present(a)) then - counter=counter+1 - a=globrbuff(counter) -! end if - if(present(b)) then - counter=counter+1 - b=globrbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=globrbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=globrbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=globrbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=globrbuff(counter) - end if - end subroutine qmpi_real_reduction - - subroutine qmpi_real8_reduction(type,a,b,c,d,e,f,root) -! -! perform a reduction of 'type' on each of the given arguments a - f. -! if type is: -! 'sum': for each argument, return the sum of the argument over all processors -! 'mul': the product -! 'min': the minimum value -! 'max': the maximum value -! root is an optional argument, if given only return the result on that processor (reduce) -! the default is to return the result on all processors (allreduce) -! - implicit none - integer, parameter :: dp=8 - character(3) type - real(dp) a - real(dp), optional, intent(inout) :: b,c,d,e,f - integer, optional :: root - integer counter,boss - real(dp) rbuff(6),globrbuff(6) - - if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then - print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported' - stop - end if - - boss=0 - if(present(root))boss=root - - globrbuff(:)=0.0 - counter=0 -! if(present(a)) then - counter=counter+1 - rbuff(counter)=a -! end if - if(present(b)) then - counter=counter+1 - rbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=f - end if - - select case(type) - case('sum') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,mpi_comm_world,ierr) - end if - case('mul') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,mpi_comm_world,ierr) - end if - case('min') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,mpi_comm_world,ierr) - end if - case('max') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,mpi_comm_world,ierr) - end if - end select - - counter=0 -! if(present(a)) then - counter=counter+1 - a=globrbuff(counter) -! end if - if(present(b)) then - counter=counter+1 - b=globrbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=globrbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=globrbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=globrbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=globrbuff(counter) - end if - end subroutine qmpi_real8_reduction - - subroutine qmpi_integer_reduction(type,a,b,c,d,e,f,root) -! -! perform a reduction of 'type' on each of the given arguments a - f. -! if type is: -! 'sum': for each argument, return the sum of the argument over all processors -! 'mul': the product -! 'min': the minimum value -! 'max': the maximum value -! root is an optional argument, if given only return the result on that processor (reduce) -! the default is to return the result on all processors (allreduce) -! - implicit none - character(3) type - integer(sp) a - integer(sp), optional, intent(inout) :: b,c,d,e,f - integer, optional :: root - integer counter,boss - integer rbuff(6),globrbuff(6) - - if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then - print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported' - stop - end if - - boss=0 - if(present(root))boss=root - - globrbuff(:)=0 - counter=0 - !if(present(a)) then - counter=counter+1 - rbuff(counter)=a - !end if - if(present(b)) then - counter=counter+1 - rbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=f - end if - - select case(type) - case('sum') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_sum,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_sum,mpi_comm_world,ierr) - end if - case('mul') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_prod,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_prod,mpi_comm_world,ierr) - end if - case('min') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_min,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_min,mpi_comm_world,ierr) - end if - case('max') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_max,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_max,mpi_comm_world,ierr) - end if - end select - - counter=0 -! if(present(a)) then - counter=counter+1 - a=globrbuff(counter) -! end if - if(present(b)) then - counter=counter+1 - b=globrbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=globrbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=globrbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=globrbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=globrbuff(counter) - end if - end subroutine qmpi_integer_reduction - - subroutine qmpi_integer8_reduction(type,a,b,c,d,e,f,root) -! -! perform a reduction of 'type' on each of the given arguments a - f. -! if type is: -! 'sum': for each argument, return the sum of the argument over all processors -! 'mul': the product -! 'min': the minimum value -! 'max': the maximum value -! root is an optional argument, if given only return the result on that processor (reduce) -! the default is to return the result on all processors (allreduce) -! - implicit none - character(3) type - integer(long) a - integer(long), optional, intent(inout) :: b,c,d,e,f - integer, optional :: root - integer counter,boss - integer(long) rbuff(6),globrbuff(6) - - if(len(type).ne.3)then - print *,'qmpi.f90 reduce error: type must be one of "mul","sum","min" or "max"' - stop - end if - if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then - print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported' - stop - end if - - boss=0 - if(present(root))boss=root - - globrbuff(:)=0_dp - counter=0 -! if(present(a)) then - counter=counter+1 - rbuff(counter)=a -! end if - if(present(b)) then - counter=counter+1 - rbuff(counter)=b - end if - if(present(c)) then - counter=counter+1 - rbuff(counter)=c - end if - if(present(d)) then - counter=counter+1 - rbuff(counter)=d - end if - if(present(e)) then - counter=counter+1 - rbuff(counter)=e - end if - if(present(f)) then - counter=counter+1 - rbuff(counter)=f - end if - - select case(type) - case('sum') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_sum,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_sum,mpi_comm_world,ierr) - end if - case('mul') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_prod,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_prod,mpi_comm_world,ierr) - end if - case('min') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_min,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_min,mpi_comm_world,ierr) - end if - case('max') - if(present(root))then - call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_max,boss,mpi_comm_world,ierr) - else - call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_max,mpi_comm_world,ierr) - end if - end select - - counter=1 - a=globrbuff(counter) - - if(present(b)) then - counter=counter+1 - b=globrbuff(counter) - end if - if(present(c)) then - counter=counter+1 - c=globrbuff(counter) - end if - if(present(d)) then - counter=counter+1 - d=globrbuff(counter) - end if - if(present(e)) then - counter=counter+1 - e=globrbuff(counter) - end if - if(present(f)) then - counter=counter+1 - f=globrbuff(counter) - end if - end subroutine qmpi_integer8_reduction - - -! later? -! packing to reduce number of sends: - -! call pack(u) -! call pack(eta(1,:)) -! call pack(v) -! call send_pack(1) -! ... -! call receive_pack(0) -! call unpack(u) -! call unpack(eta(1,:) -! - -end module qmpi - -#else - -#warning "COMPILING WITHOUT QMPI CODE" - -module qmpi_fake - implicit none - - logical, parameter :: master = .true. - integer, parameter :: qmpi_num_proc = 1 - integer, parameter :: qmpi_proc_num = 0 - -contains - - subroutine stop_mpi() - stop - end subroutine stop_mpi - -end module qmpi_fake - -#endif diff --git a/assim/enkf_cf-system2_old/EnKF/spline.F90 b/assim/enkf_cf-system2_old/EnKF/spline.F90 deleted file mode 100755 index 87f4acae..00000000 --- a/assim/enkf_cf-system2_old/EnKF/spline.F90 +++ /dev/null @@ -1,6821 +0,0 @@ -subroutine basis_function_b_val ( tdata, tval, yval ) - -!*****************************************************************************80 -! -!! BASIS_FUNCTION_B_VAL evaluates the B spline basis function. -! -! Discussion: -! -! The B spline basis function is a piecewise cubic which -! has the properties that: -! -! * it equals 2/3 at TDATA(3), 1/6 at TDATA(2) and TDATA(4); -! * it is 0 for TVAL <= TDATA(1) or TDATA(5) <= TVAL; -! * it is strictly increasing from TDATA(1) to TDATA(3), -! and strictly decreasing from TDATA(3) to TDATA(5); -! * the function and its first two derivatives are continuous -! at each node TDATA(I). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Alan Davies, Philip Samuels, -! An Introduction to Computational Geometry for Curves and Surfaces, -! Clarendon Press, 1996, -! ISBN: 0-19-851478-6, -! LC: QA448.D38. -! -! Parameters: -! -! Input, real ( kind = 8 ) TDATA(5), the nodes associated with the -! basis function. The entries of TDATA are assumed to be distinct -! and increasing. -! -! Input, real ( kind = 8 ) TVAL, a point at which the B spline basis -! function is to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the function at TVAL. -! - implicit none - - integer ( kind = 4 ), parameter :: ndata = 5 - - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) u - real ( kind = 8 ) yval - - if ( tval <= tdata(1) .or. tdata(ndata) <= tval ) then - yval = 0.0D+00 - return - end if -! -! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] containing TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! U is the normalized coordinate of TVAL in this interval. -! - u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) ) -! -! Now evaluate the function. -! - if ( tval < tdata(2) ) then - yval = u**3 / 6.0D+00 - else if ( tval < tdata(3) ) then - yval = ( ( ( - 3.0D+00 & - * u + 3.0D+00 ) & - * u + 3.0D+00 ) & - * u + 1.0D+00 ) / 6.0D+00 - else if ( tval < tdata(4) ) then - yval = ( ( ( + 3.0D+00 & - * u - 6.0D+00 ) & - * u + 0.0D+00 ) & - * u + 4.0D+00 ) / 6.0D+00 - else if ( tval < tdata(5) ) then - yval = ( 1.0D+00 - u )**3 / 6.0D+00 - end if - - return -end -subroutine basis_function_beta_val ( beta1, beta2, tdata, tval, yval ) - -!*****************************************************************************80 -! -!! BASIS_FUNCTION_BETA_VAL evaluates the beta spline basis function. -! -! Discussion: -! -! With BETA1 = 1 and BETA2 = 0, the beta spline basis function -! equals the B spline basis function. -! -! With BETA1 large, and BETA2 = 0, the beta spline basis function -! skews to the right, that is, its maximum increases, and occurs -! to the right of the center. -! -! With BETA1 = 1 and BETA2 large, the beta spline becomes more like -! a linear basis function; that is, its value in the outer two intervals -! goes to zero, and its behavior in the inner two intervals approaches -! a piecewise linear function that is 0 at the second node, 1 at the -! third, and 0 at the fourth. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Alan Davies, Philip Samuels, -! An Introduction to Computational Geometry for Curves and Surfaces, -! Clarendon Press, 1996, -! ISBN: 0-19-851478-6, -! LC: QA448.D38. -! -! Parameters: -! -! Input, real ( kind = 8 ) BETA1, the skew or bias parameter. -! BETA1 = 1 for no skew or bias. -! -! Input, real ( kind = 8 ) BETA2, the tension parameter. -! BETA2 = 0 for no tension. -! -! Input, real ( kind = 8 ) TDATA(5), the nodes associated with the -! basis function. The entries of TDATA are assumed to be distinct -! and increasing. -! -! Input, real ( kind = 8 ) TVAL, a point at which the B spline -! basis function is to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the function at TVAL. -! - implicit none - - integer ( kind = 4 ), parameter :: ndata = 5 - - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) beta1 - real ( kind = 8 ) beta2 - real ( kind = 8 ) c - real ( kind = 8 ) d - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) u - real ( kind = 8 ) yval - - if ( tval <= tdata(1) .or. tdata(ndata) <= tval ) then - yval = 0.0D+00 - return - end if -! -! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] containing TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! U is the normalized coordinate of TVAL in this interval. -! - u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) ) -! -! Now evaluate the function. -! - if ( tval < tdata(2) ) then - - yval = 2.0D+00 * u**3 - - else if ( tval < tdata(3) ) then - - a = beta2 + 4.0D+00 * beta1 + 4.0D+00 * beta1 * beta1 & - + 6.0D+00 * ( 1.0D+00 - beta1 * beta1 ) & - - 3.0D+00 * ( 2.0D+00 + beta2 + 2.0D+00 * beta1 ) & - + 2.0D+00 * ( 1.0D+00 + beta2 + beta1 + beta1 * beta1 ) - - b = - 6.0D+00 * ( 1.0D+00 - beta1 * beta1 ) & - + 6.0D+00 * ( 2.0D+00 + beta2 + 2.0D+00 * beta1 ) & - - 6.0D+00 * ( 1.0D+00 + beta2 + beta1 + beta1 * beta1 ) - - c = - 3.0D+00 * ( 2.0D+00 + beta2 + 2.0D+00 * beta1 ) & - + 6.0D+00 * ( 1.0D+00 + beta2 + beta1 + beta1 * beta1 ) - - d = - 2.0D+00 * ( 1.0D+00 + beta2 + beta1 + beta1 * beta1 ) - - yval = ( ( d * u + c ) * u + b ) * u + a - - else if ( tval < tdata(4) ) then - - a = beta2 + 4.0D+00 * beta1 + 4.0D+00 * beta1 * beta1 - - b = - 6.0D+00 * beta1 * ( 1.0D+00 - beta1 * beta1 ) - - c = - 3.0D+00 * ( beta2 + 2.0D+00 * beta1**2 + 2.0D+00 * beta1**3 ) - - d = 2.0D+00 * ( beta2 + beta1 + beta1**2 + beta1**3 ) - - yval = ( ( d * u + c ) * u + b ) * u + a - - else if ( tval < tdata(5) ) then - - yval = 2.0D+00 * beta1**3 * ( 1.0D+00 - u )**3 - - end if - - yval = yval / ( 2.0D+00 + beta2 + 4.0D+00 * beta1 + 4.0D+00 * beta1**2 & - + 2.0D+00 * beta1**3 ) - - return -end -subroutine basis_matrix_b_uni ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_B_UNI sets up the uniform B spline basis matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 June 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries vanDam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1995, -! ISBN: 0201848406, -! LC: T385.C5735. -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(4,4) -! -! In the following statement, the matrix appears as though it -! has been transposed. -! - mbasis(1:4,1:4) = real ( reshape ( & - (/ -1, 3, -3, 1, & - 3, -6, 0, 4, & - -3, 3, 3, 1, & - 1, 0, 0, 0 /), & - (/ 4, 4 /) ), kind = 8 ) / 6.0D+00 - - return -end -subroutine basis_matrix_beta_uni ( beta1, beta2, mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_BETA_UNI sets up the uniform beta spline basis matrix. -! -! Discussion: -! -! If BETA1 = 1 and BETA2 = 0, then the beta spline reduces to -! the B spline. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries vanDam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1995, -! ISBN: 0201848406, -! LC: T385.C5735. -! -! Parameters: -! -! Input, real ( kind = 8 ) BETA1, the skew or bias parameter. -! BETA1 = 1 for no skew or bias. -! -! Input, real ( kind = 8 ) BETA2, the tension parameter. -! BETA2 = 0 for no tension. -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) beta1 - real ( kind = 8 ) beta2 - real ( kind = 8 ) delta - real ( kind = 8 ) mbasis(4,4) - - mbasis(1,1) = - 2.0D+00 * beta1 * beta1 * beta1 - mbasis(1,2) = 2.0D+00 * beta2 & - + 2.0 * beta1 * ( beta1 * beta1 + beta1 + 1.0D+00 ) - mbasis(1,3) = - 2.0D+00 * ( beta2 + beta1 * beta1 + beta1 + 1.0D+00 ) - mbasis(1,4) = 2.0D+00 - - mbasis(2,1) = 6.0D+00 * beta1 * beta1 * beta1 - mbasis(2,2) = - 3.0D+00 * beta2 & - - 6.0D+00 * beta1 * beta1 * ( beta1 + 1.0D+00 ) - mbasis(2,3) = 3.0D+00 * beta2 + 6.0D+00 * beta1 * beta1 - mbasis(2,4) = 0.0D+00 - - mbasis(3,1) = - 6.0D+00 * beta1 * beta1 * beta1 - mbasis(3,2) = 6.0D+00 * beta1 * ( beta1 - 1.0D+00 ) * ( beta1 + 1.0D+00 ) - mbasis(3,3) = 6.0D+00 * beta1 - mbasis(3,4) = 0.0D+00 - - mbasis(4,1) = 2.0D+00 * beta1 * beta1 * beta1 - mbasis(4,2) = 4.0D+00 * beta1 * ( beta1 + 1.0D+00 ) + beta2 - mbasis(4,3) = 2.0D+00 - mbasis(4,4) = 0.0D+00 - - delta = ( ( 2.0D+00 & - * beta1 + 4.0D+00 ) & - * beta1 + 4.0D+00 ) & - * beta1 + 2.0D+00 + beta2 - - mbasis(1:4,1:4) = mbasis(1:4,1:4) / delta - - return -end -subroutine basis_matrix_bezier ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_BEZIER sets up the cubic Bezier spline basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points are stored as -! ( P1, P2, P3, P4 ). P1 is the function value at T = 0, while -! P2 is used to approximate the derivative at T = 0 by -! dP/dt = 3 * ( P2 - P1 ). Similarly, P4 is the function value -! at T = 1, and P3 is used to approximate the derivative at T = 1 -! by dP/dT = 3 * ( P4 - P3 ). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries vanDam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1995, -! ISBN: 0201848406, -! LC: T385.C5735. -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(4,4) - - mbasis(1,1) = -1.0D+00 - mbasis(1,2) = 3.0D+00 - mbasis(1,3) = -3.0D+00 - mbasis(1,4) = 1.0D+00 - - mbasis(2,1) = 3.0D+00 - mbasis(2,2) = -6.0D+00 - mbasis(2,3) = 3.0D+00 - mbasis(2,4) = 0.0D+00 - - mbasis(3,1) = -3.0D+00 - mbasis(3,2) = 3.0D+00 - mbasis(3,3) = 0.0D+00 - mbasis(3,4) = 0.0D+00 - - mbasis(4,1) = 1.0D+00 - mbasis(4,2) = 0.0D+00 - mbasis(4,3) = 0.0D+00 - mbasis(4,4) = 0.0D+00 - - return -end -subroutine basis_matrix_hermite ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_HERMITE sets up the Hermite spline basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points are stored as -! ( P1, P2, P1', P2' ), with P1 and P1' being the data value and -! the derivative dP/dT at T = 0, while P2 and P2' apply at T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries vanDam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1995, -! ISBN: 0201848406, -! LC: T385.C5735. -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(4,4) - - mbasis(1,1) = 2.0D+00 - mbasis(1,2) = -2.0D+00 - mbasis(1,3) = 1.0D+00 - mbasis(1,4) = 1.0D+00 - - mbasis(2,1) = -3.0D+00 - mbasis(2,2) = 3.0D+00 - mbasis(2,3) = -2.0D+00 - mbasis(2,4) = -1.0D+00 - - mbasis(3,1) = 0.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 1.0D+00 - mbasis(3,4) = 0.0D+00 - - mbasis(4,1) = 1.0D+00 - mbasis(4,2) = 0.0D+00 - mbasis(4,3) = 0.0D+00 - mbasis(4,4) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_nonuni ( alpha, beta, mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_NONUNI: nonuniform Overhauser spline basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points P1, P2, P3 and -! P4 are not uniformly spaced in T, and that P2 corresponds to T = 0, -! and P3 to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ALPHA, BETA. -! ALPHA = || P2 - P1 || / ( || P3 - P2 || + || P2 - P1 || ) -! BETA = || P3 - P2 || / ( || P4 - P3 || + || P3 - P2 || ). -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) alpha - real ( kind = 8 ) beta - real ( kind = 8 ) mbasis(4,4) - - mbasis(1,1) = - ( 1.0D+00 - alpha ) * ( 1.0D+00 - alpha ) / alpha - mbasis(1,2) = beta + ( 1.0D+00 - alpha ) / alpha - mbasis(1,3) = alpha - 1.0D+00 / ( 1.0D+00 - beta ) - mbasis(1,4) = beta * beta / ( 1.0D+00 - beta ) - - mbasis(2,1) = 2.0D+00 * ( 1.0D+00 - alpha ) * ( 1.0D+00 - alpha ) / alpha - mbasis(2,2) = ( - 2.0D+00 * ( 1.0D+00 - alpha ) - alpha * beta ) / alpha - mbasis(2,3) = ( 2.0D+00 * ( 1.0D+00 - alpha ) & - - beta * ( 1.0D+00 - 2.0D+00 * alpha ) ) / ( 1.0D+00 - beta ) - mbasis(2,4) = - beta * beta / ( 1.0D+00 - beta ) - - mbasis(3,1) = - ( 1.0D+00 - alpha ) * ( 1.0D+00 - alpha ) / alpha - mbasis(3,2) = ( 1.0D+00 - 2.0D+00 * alpha ) / alpha - mbasis(3,3) = alpha - mbasis(3,4) = 0.0D+00 - - mbasis(4,1) = 0.0D+00 - mbasis(4,2) = 1.0D+00 - mbasis(4,3) = 0.0D+00 - mbasis(4,4) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_nul ( alpha, mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_NUL sets the nonuniform left Overhauser basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points P1, P2, and -! P3 are not uniformly spaced in T, and that P1 corresponds to T = 0, -! and P2 to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 August 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ALPHA. -! ALPHA = || P2 - P1 || / ( || P3 - P2 || + || P2 - P1 || ) -! -! Output, real ( kind = 8 ) MBASIS(3,3), the basis matrix. -! - implicit none - - real ( kind = 8 ) alpha - real ( kind = 8 ) mbasis(3,3) - - mbasis(1,1) = 1.0D+00 / alpha - mbasis(1,2) = - 1.0D+00 / ( alpha * ( 1.0D+00 - alpha ) ) - mbasis(1,3) = 1.0D+00 / ( 1.0D+00 - alpha ) - - mbasis(2,1) = - ( 1.0D+00 + alpha ) / alpha - mbasis(2,2) = 1.0D+00 / ( alpha * ( 1.0D+00 - alpha ) ) - mbasis(2,3) = - alpha / ( 1.0D+00 - alpha ) - - mbasis(3,1) = 1.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_nur ( beta, mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_NUR: the nonuniform right Overhauser basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points PN-2, PN-1, and -! PN are not uniformly spaced in T, and that PN-1 corresponds to T = 0, -! and PN to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 August 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) BETA. -! BETA = || P(N) - P(N-1) || -! / ( || P(N) - P(N-1) || + || P(N-1) - P(N-2) || ) -! -! Output, real ( kind = 8 ) MBASIS(3,3), the basis matrix. -! - implicit none - - real ( kind = 8 ) beta - real ( kind = 8 ) mbasis(3,3) - - mbasis(1,1) = 1.0D+00 / beta - mbasis(1,2) = - 1.0D+00 / ( beta * ( 1.0D+00 - beta ) ) - mbasis(1,3) = 1.0D+00 / ( 1.0D+00 - beta ) - - mbasis(2,1) = - ( 1.0D+00 + beta ) / beta - mbasis(2,2) = 1.0D+00 / ( beta * ( 1.0D+00 - beta ) ) - mbasis(2,3) = - beta / ( 1.0D+00 - beta ) - - mbasis(3,1) = 1.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_uni ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_UNI sets the uniform Overhauser spline basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points P1, P2, P3 and -! P4 are uniformly spaced in T, and that P2 corresponds to T = 0, -! and P3 to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries vanDam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1995, -! ISBN: 0201848406, -! LC: T385.C5735. -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(4,4), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(4,4) - - mbasis(1,1) = - 1.0D+00 / 2.0D+00 - mbasis(1,2) = 3.0D+00 / 2.0D+00 - mbasis(1,3) = - 3.0D+00 / 2.0D+00 - mbasis(1,4) = 1.0D+00 / 2.0D+00 - - mbasis(2,1) = 2.0D+00 / 2.0D+00 - mbasis(2,2) = - 5.0D+00 / 2.0D+00 - mbasis(2,3) = 4.0D+00 / 2.0D+00 - mbasis(2,4) = - 1.0D+00 / 2.0D+00 - - mbasis(3,1) = - 1.0D+00 / 2.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 1.0D+00 / 2.0D+00 - mbasis(3,4) = 0.0D+00 - - mbasis(4,1) = 0.0D+00 - mbasis(4,2) = 2.0D+00 / 2.0D+00 - mbasis(4,3) = 0.0D+00 - mbasis(4,4) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_uni_l ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_UNI_L sets the left uniform Overhauser basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points P1, P2, and P3 -! are not uniformly spaced in T, and that P1 corresponds to T = 0, -! and P2 to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(3,3), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(3,3) - - mbasis(1,1) = 2.0D+00 - mbasis(1,2) = - 4.0D+00 - mbasis(1,3) = 2.0D+00 - - mbasis(2,1) = - 3.0D+00 - mbasis(2,2) = 4.0D+00 - mbasis(2,3) = - 1.0D+00 - - mbasis(3,1) = 1.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 0.0D+00 - - return -end -subroutine basis_matrix_overhauser_uni_r ( mbasis ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_OVERHAUSER_UNI_R sets the right uniform Overhauser basis matrix. -! -! Discussion: -! -! This basis matrix assumes that the data points P(N-2), P(N-1), -! and P(N) are uniformly spaced in T, and that P(N-1) corresponds to -! T = 0, and P(N) to T = 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) MBASIS(3,3), the basis matrix. -! - implicit none - - real ( kind = 8 ) mbasis(3,3) - - mbasis(1,1) = 2.0D+00 - mbasis(1,2) = - 4.0D+00 - mbasis(1,3) = 2.0D+00 - - mbasis(2,1) = - 3.0D+00 - mbasis(2,2) = 4.0D+00 - mbasis(2,3) = - 1.0D+00 - - mbasis(3,1) = 1.0D+00 - mbasis(3,2) = 0.0D+00 - mbasis(3,3) = 0.0D+00 - - return -end -subroutine basis_matrix_tmp ( left, n, mbasis, ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! BASIS_MATRIX_TMP computes Q = T * MBASIS * P -! -! Discussion: -! -! YDATA is a vector of data values, most frequently the values of some -! function sampled at uniformly spaced points. MBASIS is the basis -! matrix for a particular kind of spline. T is a vector of the -! powers of the normalized difference between TVAL and the left -! endpoint of the interval. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 February 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) LEFT, indicats that TVAL is in the interval -! [ TDATA(LEFT), TDATA(LEFT+1) ], or that this is the "nearest" -! interval to TVAL. -! For TVAL < TDATA(1), use LEFT = 1. -! For TDATA(NDATA) < TVAL, use LEFT = NDATA - 1. -! -! Input, integer ( kind = 4 ) N, the order of the basis matrix. -! -! Input, real ( kind = 8 ) MBASIS(N,N), the basis matrix. -! -! Input, integer ( kind = 4 ) NDATA, the dimension of the vectors TDATA -! and YDATA. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissa values. This routine -! assumes that the TDATA values are uniformly spaced, with an -! increment of 1.0. -! -! Input, real ( kind = 8 ) YDATA(NDATA), the data values to be -! interpolated or approximated. -! -! Input, real ( kind = 8 ) TVAL, the value of T at which the spline is to be -! evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the spline at TVAL. -! - implicit none - - integer ( kind = 4 ), parameter :: maxn = 4 - integer ( kind = 4 ) n - integer ( kind = 4 ) ndata - - real ( kind = 8 ) arg - integer ( kind = 4 ) first - integer ( kind = 4 ) i - integer ( kind = 4 ) j - integer ( kind = 4 ) left - real ( kind = 8 ) mbasis(n,n) - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) tvec(maxn) - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval - - if ( left == 1 ) then - arg = 0.5D+00 * ( tval - tdata(left) ) - first = left - else if ( left < ndata - 1 ) then - arg = tval - tdata(left) - first = left - 1 - else if ( left == ndata - 1 ) then - arg = 0.5D+00 * ( 1.0D+00 + tval - tdata(left) ) - first = left - 1 - end if -! -! TVEC(I) = ARG^(N-I). -! - tvec(n) = 1.0D+00 - do i = n-1, 1, -1 - tvec(i) = arg * tvec(i+1) - end do - - yval = 0.0D+00 - do j = 1, n - yval = yval + dot_product ( tvec(1:n), mbasis(1:n,j) ) & - * ydata(first - 1 + j) - end do - - return -end -subroutine bc_val ( n, t, xcon, ycon, xval, yval ) - -!*****************************************************************************80 -! -!! BC_VAL evaluates a parameterized N-th degree Bezier curve in 2D. -! -! Discussion: -! -! BC_VAL(T) is the value of a vector function of the form -! -! BC_VAL(T) = ( X(T), Y(T) ) -! -! where -! -! X(T) = sum ( 0 <= I <= N ) XCON(I) * BERN(I,N)(T) -! Y(T) = sum ( 0 <= I <= N ) YCON(I) * BERN(I,N)(T) -! -! BERN(I,N)(T) is the I-th Bernstein polynomial of order N -! defined on the interval [0,1], -! -! XCON(0:N) and YCON(0:N) are the coordinates of N+1 "control points". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the degree of the Bezier curve. -! N must be at least 0. -! -! Input, real ( kind = 8 ) T, the point at which the Bezier curve should -! be evaluated. The best results are obtained within the interval -! [0,1] but T may be anywhere. -! -! Input, real ( kind = 8 ) XCON(0:N), YCON(0:N), the X and Y coordinates -! of the control points. The Bezier curve will pass through -! the points ( XCON(0), YCON(0) ) and ( XCON(N), YCON(N) ), but -! generally NOT through the other control points. -! -! Output, real ( kind = 8 ) XVAL, YVAL, the X and Y coordinates of the point -! on the Bezier curve corresponding to the given T value. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) bval(0:n) - real ( kind = 8 ) t - real ( kind = 8 ) xcon(0:n) - real ( kind = 8 ) xval - real ( kind = 8 ) ycon(0:n) - real ( kind = 8 ) yval - - call bp01 ( n, t, bval ) - - xval = dot_product ( xcon(0:n), bval(0:n) ) - yval = dot_product ( ycon(0:n), bval(0:n) ) - - return -end -function bez_val ( n, x, a, b, y ) - -!*****************************************************************************80 -! -!! BEZ_VAL evaluates an N-th degree Bezier function at a point. -! -! Discussion: -! -! The Bezier function has the form: -! -! BEZ(X) = sum ( 0 <= I <= N ) Y(I) * BERN(N,I)( (X-A)/(B-A) ) -! -! BERN(N,I)(X) is the I-th Bernstein polynomial of order N -! defined on the interval [0,1], -! -! Y(0:N) is a set of coefficients, -! -! and if, for I = 0 to N, we define the N+1 points -! -! X(I) = ( (N-I)*A + I*B) / N, -! -! equally spaced in [A,B], the pairs ( X(I), Y(I) ) can be regarded as -! "control points". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the degree of the Bezier function. -! N must be at least 0. -! -! Input, real ( kind = 8 ) X, the point at which the Bezier function should -! be evaluated. The best results are obtained within the interval -! [A,B] but X may be anywhere. -! -! Input, real ( kind = 8 ) A, B, the interval over which the Bezier function -! has been defined. This is the interval in which the control -! points have been set up. Note BEZ(A) = Y(0) and BEZ(B) = Y(N), -! although BEZ will not, in general pass through the other -! control points. A and B must not be equal. -! -! Input, real ( kind = 8 ) Y(0:N), a set of data defining the Y coordinates -! of the control points. -! -! Output, real ( kind = 8 ) BEZ_VAL, the value of the Bezier function at X. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) bez_val - real ( kind = 8 ) bval(0:n) - real ( kind = 8 ) x - real ( kind = 8 ) x01 - real ( kind = 8 ) y(0:n) - - if ( b - a == 0.0D+00 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'BEZ_VAL - Fatal error!' - write ( *, '(a,g14.6)' ) ' Null interval, A = B = ', a - stop 1 - end if -! -! X01 lies in [0,1], in the same relative position as X in [A,B]. -! - x01 = ( x - a ) / ( b - a ) - - call bp01 ( n, x01, bval ) - - bez_val = dot_product ( y(0:n), bval(0:n) ) - - return -end -subroutine bp01 ( n, x, bern ) - -!*****************************************************************************80 -! -!! BP01 evaluates the Bernstein basis polynomials for [0,1] at a point. -! -! Discussion: -! -! For any N greater than or equal to 0, there is a set of N+1 Bernstein -! basis polynomials, each of degree N, which form a basis for -! all polynomials of degree N on [0,1]. -! -! BERN(N,I,X) = [N!/(I!*(N-I)!)] * (1-X)^(N-I) * X^I -! -! N is the degree; -! -! 0 <= I <= N indicates which of the N+1 basis polynomials -! of degree N to choose; -! -! X is a point in [0,1] at which to evaluate the basis polynomial. -! -! First values: -! -! B(0,0,X) = 1 -! -! B(1,0,X) = 1-X -! B(1,1,X) = X -! -! B(2,0,X) = (1-X)^2 -! B(2,1,X) = 2 * (1-X) * X -! B(2,2,X) = X^2 -! -! B(3,0,X) = (1-X)^3 -! B(3,1,X) = 3 * (1-X)^2 * X -! B(3,2,X) = 3 * (1-X) * X^2 -! B(3,3,X) = X^3 -! -! B(4,0,X) = (1-X)^4 -! B(4,1,X) = 4 * (1-X)^3 * X -! B(4,2,X) = 6 * (1-X)^2 * X^2 -! B(4,3,X) = 4 * (1-X) * X^3 -! B(4,4,X) = X^4 -! -! Special values: -! -! B(N,I,1/2) = C(N,K) / 2^N -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the degree of the Bernstein basis -! polynomials. N must be at least 0. -! -! Input, real ( kind = 8 ) X, the evaluation point. -! -! Output, real ( kind = 8 ) BERN(0:N), the values of the N+1 Bernstein basis -! polynomials at X. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) bern(0:n) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - real ( kind = 8 ) x - - if ( n == 0 ) then - - bern(0) = 1.0D+00 - - else if ( 0 < n ) then - - bern(0) = 1.0D+00 - x - bern(1) = x - - do i = 2, n - bern(i) = x * bern(i-1) - do j = i-1, 1, -1 - bern(j) = x * bern(j-1) + ( 1.0D+00 - x ) * bern(j) - end do - bern(0) = ( 1.0D+00 - x ) * bern(0) - end do - - end if - - return -end -subroutine bpab ( n, a, b, x, bern ) - -!*****************************************************************************80 -! -!! BPAB evaluates the Bernstein basis polynomials for [A,B] at a point. -! -! Discussion: -! -! BERN(N,I,X) = [N!/(I!*(N-I)!)] * (B-X)^(N-I) * (X-A)^I / (B-A)^N -! -! B(0,0,X) = 1 -! -! B(1,0,X) = ( B-X ) / (B-A) -! B(1,1,X) = ( X-A ) / (B-A) -! -! B(2,0,X) = ( (B-X)^2 ) / (B-A)^2 -! B(2,1,X) = ( 2 * (B-X * (X-A) ) / (B-A)^2 -! B(2,2,X) = ( (X-A)^2 ) / (B-A)^2 -! -! B(3,0,X) = ( (B-X)^3 ) / (B-A)^3 -! B(3,1,X) = ( 3 * (B-X)^2 * (X-A) ) / (B-A)^3 -! B(3,2,X) = ( 3 * (B-X) * (X-A)^2 ) / (B-A)^3 -! B(3,3,X) = ( (X-A)^3 ) / (B-A)^3 -! -! B(4,0,X) = ( (B-X)^4 ) / (B-A)^4 -! B(4,1,X) = ( 4 * (B-X)^3 * (X-A) ) / (B-A)^4 -! B(4,2,X) = ( 6 * (B-X)^2 * (X-A)^2 ) / (B-A)^4 -! B(4,3,X) = ( 4 * (B-X) * (X-A)^3 ) / (B-A)^4 -! B(4,4,X) = ( (X-A)^4 ) / (B-A)^4 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the degree of the Bernstein basis -! polynomials. There is a set of N+1 Bernstein basis polynomials, each -! of degree N, which form a basis for polynomials of degree N on [A,B]. -! N must be at least 0. -! -! Input, real ( kind = 8 ) A, B, the endpoints of the interval on which the -! polynomials are to be based. A and B should not be equal. -! Input, real ( kind = 8 ) X, the point at which the polynomials are to be -! evaluated. X need not lie in the interval [A,B]. -! -! Output, real ( kind = 8 ) BERN(0:N), the values of the N+1 Bernstein basis -! polynomials at X. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) bern(0:n) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - real ( kind = 8 ) x - - if ( b == a ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'BPAB - Fatal error!' - write ( *, '(a,g14.6)' ) ' A = B = ', a - stop 1 - end if - - if ( n == 0 ) then - - bern(0) = 1.0D+00 - - else if ( 0 < n ) then - - bern(0) = ( b - x ) / ( b - a ) - bern(1) = ( x - a ) / ( b - a ) - - do i = 2, n - bern(i) = ( x - a ) * bern(i-1) / ( b - a ) - do j = i-1, 1, -1 - bern(j) = ( ( b - x ) * bern(j) + ( x - a ) * bern(j-1) ) / ( b - a ) - end do - bern(0) = ( b - x ) * bern(0) / ( b - a ) - end do - - end if - - return -end -subroutine bpab_approx ( n, a, b, ydata, xval, yval ) - -!*****************************************************************************80 -! -!! BPAB_APPROX evaluates the Bernstein polynomial approximant to F(X) on [A,B]. -! -! Formula: -! -! BERN(F)(X) = sum ( 0 <= I <= N ) F(X(I)) * B_BASE(I,X) -! -! where -! -! X(I) = ( ( N - I ) * A + I * B ) / N -! B_BASE(I,X) is the value of the I-th Bernstein basis polynomial at X. -! -! Discussion: -! -! The Bernstein polynomial BERN(F) for F(X) is an approximant, not an -! interpolant; in other words, its value is not guaranteed to equal -! that of F at any particular point. However, for a fixed interval -! [A,B], if we let N increase, the Bernstein polynomial converges -! uniformly to F everywhere in [A,B], provided only that F is continuous. -! Even if F is not continuous, but is bounded, the polynomial converges -! pointwise to F(X) at all points of continuity. On the other hand, -! the convergence is quite slow compared to other interpolation -! and approximation schemes. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the degree of the Bernstein polynomial -! to be used. N must be at least 0. -! -! Input, real ( kind = 8 ) A, B, the endpoints of the interval on which the -! approximant is based. A and B should not be equal. -! -! Input, real ( kind = 8 ) YDATA(0:N), the data values at N+1 equally -! spaced points in [A,B]. If N = 0, then the evaluation point should -! be 0.5 * ( A + B). Otherwise, evaluation point I should be -! ( (N-I)*A + I*B ) / N ). -! -! Input, real ( kind = 8 ) XVAL, the point at which the Bernstein polynomial -! approximant is to be evaluated. XVAL does not have to lie in the -! interval [A,B]. -! -! Output, real ( kind = 8 ) YVAL, the value of the Bernstein polynomial -! approximant for F, based in [A,B], evaluated at XVAL. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) bvec(0:n) - real ( kind = 8 ) xval - real ( kind = 8 ) ydata(0:n) - real ( kind = 8 ) yval -! -! Evaluate the Bernstein basis polynomials at XVAL. -! - call bpab ( n, a, b, xval, bvec ) -! -! Now compute the sum of YDATA(I) * BVEC(I). -! - yval = dot_product ( ydata(0:n), bvec(0:n) ) - - return -end -subroutine chfev ( x1, x2, f1, f2, d1, d2, ne, xe, fe, next, ierr ) - -!*****************************************************************************80 -! -!! CHFEV evaluates a cubic polynomial given in Hermite form. -! -! Discussion: -! -! This routine evaluates a cubic polynomial given in Hermite form at an -! array of points. While designed for use by SPLINE_PCHIP_VAL, it may -! be useful directly as an evaluator for a piecewise cubic -! Hermite function in applications, such as graphing, where -! the interval is known in advance. -! -! The cubic polynomial is determined by function values -! F1, F2 and derivatives D1, D2 on the interval [X1,X2]. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! Original FORTRAN77 version by Fred Fritsch. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Fred Fritsch, Ralph Carlson, -! Monotone Piecewise Cubic Interpolation, -! SIAM Journal on Numerical Analysis, -! Volume 17, Number 2, April 1980, pages 238-246. -! -! David Kahaner, Cleve Moler, Steven Nash, -! Numerical Methods and Software, -! Prentice Hall, 1989, -! ISBN: 0-13-627258-4, -! LC: TA345.K34. -! -! Parameters: -! -! Input, real ( kind = 8 ) X1, X2, the endpoints of the interval of -! definition of the cubic. X1 and X2 must be distinct. -! -! Input, real ( kind = 8 ) F1, F2, the values of the function at X1 and -! X2, respectively. -! -! Input, real ( kind = 8 ) D1, D2, the derivative values at X1 and -! X2, respectively. -! -! Input, integer ( kind = 4 ) NE, the number of evaluation points. -! -! Input, real ( kind = 8 ) XE(NE), the points at which the function is to -! be evaluated. If any of the XE are outside the interval -! [X1,X2], a warning error is returned in NEXT. -! -! Output, real ( kind = 8 ) FE(NE), the value of the cubic function -! at the points XE. -! -! Output, integer ( kind = 4 ) NEXT(2), indicates the number of -! extrapolation points: -! NEXT(1) = number of evaluation points to the left of interval. -! NEXT(2) = number of evaluation points to the right of interval. -! -! Output, integer ( kind = 4 ) IERR, error flag. -! 0, no errors. -! -1, NE < 1. -! -2, X1 == X2. -! - implicit none - - integer ( kind = 4 ) ne - - real ( kind = 8 ) c2 - real ( kind = 8 ) c3 - real ( kind = 8 ) d1 - real ( kind = 8 ) d2 - real ( kind = 8 ) del1 - real ( kind = 8 ) del2 - real ( kind = 8 ) delta - real ( kind = 8 ) f1 - real ( kind = 8 ) f2 - real ( kind = 8 ) fe(ne) - real ( kind = 8 ) h - integer ( kind = 4 ) i - integer ( kind = 4 ) ierr - integer ( kind = 4 ) next(2) - real ( kind = 8 ) x - real ( kind = 8 ) x1 - real ( kind = 8 ) x2 - real ( kind = 8 ) xe(ne) - real ( kind = 8 ) xma - real ( kind = 8 ) xmi - - if ( ne < 1 ) then - ierr = -1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'CHFEV - Fatal error!' - write ( *, '(a)' ) ' Number of evaluation points is less than 1.' - write ( *, '(a,i8)' ) ' NE = ', ne - stop 1 - end if - - h = x2 - x1 - - if ( h == 0.0D+00 ) then - ierr = -2 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'CHFEV - Fatal error!' - write ( *, '(a)' ) ' The interval [X1,X2] is of zero length.' - stop 1 - end if -! -! Initialize. -! - ierr = 0 - next(1) = 0 - next(2) = 0 - xmi = min ( 0.0D+00, h ) - xma = max ( 0.0D+00, h ) -! -! Compute cubic coefficients expanded about X1. -! - delta = ( f2 - f1 ) / h - del1 = ( d1 - delta ) / h - del2 = ( d2 - delta ) / h - c2 = -( del1 + del1 + del2 ) - c3 = ( del1 + del2 ) / h -! -! Evaluation loop. -! - do i = 1, ne - - x = xe(i) - x1 - fe(i) = f1 + x * ( d1 + x * ( c2 + x * c3 ) ) -! -! Count the extrapolation points. -! - if ( x < xmi ) then - next(1) = next(1) + 1 - end if - - if ( xma < x ) then - next(2) = next(2) + 1 - end if - - end do - - return -end -subroutine data_to_dif ( ntab, xtab, ytab, diftab ) - -!*****************************************************************************80 -! -!! DATA_TO_DIF sets up a divided difference table from raw data. -! -! Discussion: -! -! Space can be saved by using a single array for both the DIFTAB and -! YTAB dummy parameters. In that case, the divided difference table will -! overwrite the Y data without interfering with the computation. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 September 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NTAB, the number of pairs of points -! (XTAB(I),YTAB(I)) which are to be used as data. The -! number of entries to be used in DIFTAB, XTAB and YTAB. -! -! Input, real ( kind = 8 ) XTAB(NTAB), the X values at which data was taken. -! These values must be distinct. -! -! Input, real ( kind = 8 ) YTAB(NTAB), the corresponding Y values. -! -! Output, real ( kind = 8 ) DIFTAB(NTAB), the divided difference coefficients -! corresponding to the input (XTAB,YTAB). -! - implicit none - - integer ( kind = 4 ) ntab - - real ( kind = 8 ) diftab(ntab) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - logical r8vec_distinct - real ( kind = 8 ) xtab(ntab) - real ( kind = 8 ) ytab(ntab) - - if ( .not. r8vec_distinct ( ntab, xtab ) ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'DATA_TO_DIF - Fatal error!' - write ( *, '(a)' ) ' Two entries of XTAB are equal!' - return - end if -! -! Copy the data values into DIFTAB. -! - diftab(1:ntab) = ytab(1:ntab) -! -! Compute the divided differences. -! - do i = 2, ntab - do j = ntab, i, -1 - - diftab(j) = ( diftab(j) - diftab(j-1) ) / ( xtab(j) - xtab(j+1-i) ) - - end do - end do - - return -end -subroutine dif_val ( ntab, xtab, diftab, xval, yval ) - -!*****************************************************************************80 -! -!! DIF_VAL evaluates a divided difference polynomial at a point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 September 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NTAB, the number of divided difference -! coefficients in DIFTAB, and the number of points XTAB. -! -! Input, real ( kind = 8 ) XTAB(NTAB), the X values upon which the -! divided difference polynomial is based. -! -! Input, real ( kind = 8 ) DIFTAB(NTAB), the divided difference -! polynomial coefficients. -! -! Input, real ( kind = 8 ) XVAL, the value where the polynomial -! is to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the polynomial at XVAL. -! - implicit none - - integer ( kind = 4 ) ntab - - real ( kind = 8 ) diftab(ntab) - integer ( kind = 4 ) i - real ( kind = 8 ) xtab(ntab) - real ( kind = 8 ) xval - real ( kind = 8 ) yval - - yval = diftab(ntab) - do i = 1, ntab-1 - yval = diftab(ntab-i) + ( xval - xtab(ntab-i) ) * yval - end do - - return -end -subroutine least_set_old ( ntab, xtab, ytab, ndeg, ptab, b, c, d, eps, ierror ) - -!*****************************************************************************80 -! -!! LEAST_SET_OLD constructs the least squares polynomial approximation to data. -! -! Discussion: -! -! The least squares polynomial is not returned directly as a simple -! polynomial. Instead, it is represented in terms of a set of -! orthogonal polynomials appopriate for the given data. This makes -! the computation more accurate, but means that the user can not -! easily evaluate the computed polynomial. Instead, the routine -! LEAST_EVAL should be used to evaluate the least squares polynomial -! at any point. (However, the value of the least squares polynomial -! at each of the data points is returned as part of this computation.) -! -! -! A discrete unweighted inner product is used, so that -! -! ( F(X), G(X) ) = sum ( 1 <= I <= NTAB ) F(XTAB(I)) * G(XTAB(I)). -! -! The least squares polynomial is determined using a set of -! orthogonal polynomials PHI. These polynomials can be defined -! recursively by: -! -! PHI(0)(X) = 1 -! PHI(1)(X) = X - B(1) -! PHI(I)(X) = ( X - B(I) ) * PHI(I-1)(X) - D(I) * PHI(I-2)(X) -! -! The array B(1:NDEG) contains the values -! -! B(I) = ( X*PHI(I-1), PHI(I-1) ) / ( PHI(I-1), PHI(I-1) ) -! -! The array D(2:NDEG) contains the values -! -! D(I) = ( PHI(I-1), PHI(I-1) ) / ( PHI(I-2), PHI(I-2) ) -! -! Using this basis, the least squares polynomial can be represented as -! -! P(X)(I) = sum ( 0 <= I <= NDEG ) C(I) * PHI(I)(X) -! -! The array C(0:NDEG) contains the values -! -! C(I) = ( YTAB(I), PHI(I) ) / ( PHI(I), PHI(I) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 May 2004 -! -! Author: -! -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! Gisela Engeln-Muellges, Frank Uhlig, -! Numerical Algorithms with C, -! Springer, 1996, -! ISBN: 3-540-60530-4. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NTAB, the number of data points. -! -! Input, real ( kind = 8 ) XTAB(NTAB), the X data. The values in XTAB -! should be distinct, and in increasing order. -! -! Input, real ( kind = 8 ) YTAB(NTAB), the Y data values corresponding -! to the X data in XTAB. -! -! Input, integer ( kind = 4 ) NDEG, the degree of the polynomial which the -! program is to use. NDEG must be at least 0, and less than or -! equal to NTAB-1. -! -! Output, real ( kind = 8 ) PTAB(NTAB), the value of the least -! squares polynomial at the points XTAB(1:NTAB). -! -! Output, real ( kind = 8 ) B(1:NDEG), C(0:NDEG), D(2:NDEG), arrays -! needed to evaluate the polynomial. -! -! Output, real ( kind = 8 ) EPS, the root-mean-square discrepancy of the -! polynomial fit. -! -! Output, integer ( kind = 4 ) IERROR, error flag. -! zero, no error occurred; -! nonzero, an error occurred, and the polynomial could not be computed. -! - implicit none - - integer ( kind = 4 ) ndeg - integer ( kind = 4 ) ntab - - real ( kind = 8 ) b(1:ndeg) - real ( kind = 8 ) c(0:ndeg) - real ( kind = 8 ) d(2:ndeg) - real ( kind = 8 ) eps - integer ( kind = 4 ) i - integer ( kind = 4 ) i0l1 - integer ( kind = 4 ) i1l1 - integer ( kind = 4 ) ierror - integer ( kind = 4 ) it - integer ( kind = 4 ) k - integer ( kind = 4 ) mdeg - real ( kind = 8 ) ptab(ntab) - real ( kind = 8 ) rn0 - real ( kind = 8 ) rn1 - real ( kind = 8 ) s - real ( kind = 8 ) sum2 - real ( kind = 8 ) xtab(ntab) - real ( kind = 8 ) y_sum - real ( kind = 8 ) ytab(ntab) - real ( kind = 8 ) ztab(2*ntab) - - ierror = 0 -! -! Check NDEG. -! - if ( ndeg < 0 ) then - ierror = 1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'LEAST_SET_OLD - Fatal error!' - write ( *, '(a)' ) ' NDEG < 0.' - stop 1 - end if - - if ( ntab <= ndeg ) then - ierror = 1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'LEAST_SET_OLD - Fatal error!' - write ( *, '(a)' ) ' NTAB <= NDEG.' - stop 1 - end if -! -! Check that the abscissas are strictly increasing. -! - do i = 1, ntab-1 - if ( xtab(i+1) <= xtab(i) ) then - ierror = 1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'LEAST_SET_OLD - Fatal error!' - write ( *, '(a)' ) ' XTAB must be strictly increasing, but' - write ( *, '(a,i8,a,g14.6)' ) ' XTAB(', i, ') = ', xtab(i) - write ( *, '(a,i8,a,g14.6)' ) ' XTAB(', i+1, ') = ', xtab(i+1) - stop 1 - end if - end do - - i0l1 = 0 - i1l1 = ntab -! -! The polynomial is of degree at least 0. -! - y_sum = sum ( ytab(1:ntab) ) - rn0 = ntab - c(0) = y_sum / real ( ntab, kind = 8 ) - - ptab(1:ntab) = y_sum / real ( ntab, kind = 8 ) - - if ( ndeg == 0 ) then - eps = sum ( ( ptab(1:ntab) - ytab(1:ntab) )**2 ) - eps = sqrt ( eps / real ( ntab, kind = 8 ) ) - return - end if -! -! The polynomial is of degree at least 1. -! - b(1) = sum ( xtab(1:ntab) ) / real ( ntab, kind = 8 ) - - s = 0.0D+00 - sum2 = 0.0D+00 - do i = 1, ntab - ztab(i1l1+i) = xtab(i) - b(1) - s = s + ztab(i1l1+i)**2 - sum2 = sum2 + ztab(i1l1+i) * ( ytab(i) - ptab(i) ) - end do - - rn1 = s - c(1) = sum2 / s - - do i = 1, ntab - ptab(i) = ptab(i) + c(1) * ztab(i1l1+i) - end do - - if ( ndeg == 1 ) then - eps = sum ( ( ptab(1:ntab) - ytab(1:ntab) )**2 ) - eps = sqrt ( eps / real ( ntab, kind = 8 ) ) - return - end if - - ztab(1:ntab) = 1.0D+00 - - mdeg = 2 - k = 2 - - do - - d(k) = rn1 / rn0 - - sum2 = 0.0D+00 - do i = 1, ntab - sum2 = sum2 + xtab(i) * ztab(i1l1+i) * ztab(i1l1+i) - end do - - b(k) = sum2 / rn1 - - s = 0.0D+00 - sum2 = 0.0D+00 - do i = 1, ntab - ztab(i0l1+i) = ( xtab(i) - b(k) ) * ztab(i1l1+i) & - - d(k) * ztab(i0l1+i) - s = s + ztab(i0l1+i) * ztab(i0l1+i) - sum2 = sum2 + ztab(i0l1+i) * ( ytab(i) - ptab(i) ) - end do - - rn0 = rn1 - rn1 = s - - c(k) = sum2 / rn1 - - it = i0l1 - i0l1 = i1l1 - i1l1 = it - - do i = 1, ntab - ptab(i) = ptab(i) + c(k) * ztab(i1l1+i) - end do - - if ( ndeg <= mdeg ) then - exit - end if - - mdeg = mdeg + 1 - k = k + 1 - - end do -! -! Compute the RMS error. -! - eps = sum ( ( ptab(1:ntab) - ytab(1:ntab) )**2 ) - eps = sqrt ( eps / real ( ntab, kind = 8 ) ) - - return -end -subroutine least_val_old ( x, ndeg, b, c, d, value ) - -!*****************************************************************************80 -! -!! LEAST_VAL_OLD evaluates a least squares polynomial defined by LEAST_SET_OLD. -! -! Discussion: -! -! This is an "old" version of the routine. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 May 2004 -! -! Author: -! -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! Gisela Engeln-Muellges, Frank Uhlig, -! Numerical Algorithms with C, -! Springer, 1996, -! ISBN: 3-540-60530-4. -! -! Parameters: -! -! Input, real ( kind = 8 ) X, the point at which the polynomial is -! to be evaluated. -! -! Input, integer ( kind = 4 ) NDEG, the degree of the least squares -! polynomial. -! -! Input, real ( kind = 8 ) B(1:NDEG), C(0:NDEG), D(2:NDEG), arrays -! defined by LEAST_SET_OLD, and needed to evaluate the polynomial. -! -! Output, real ( kind = 8 ) VALUE, the value of the polynomial at X. -! - implicit none - - integer ( kind = 4 ) ndeg - - real ( kind = 8 ) b(1:ndeg) - real ( kind = 8 ) c(0:ndeg) - real ( kind = 8 ) d(2:ndeg) - integer ( kind = 4 ) k - real ( kind = 8 ) sk - real ( kind = 8 ) skp1 - real ( kind = 8 ) skp2 - real ( kind = 8 ) value - real ( kind = 8 ) x - - if ( ndeg <= 0 ) then - - value = c(0) - - else if ( ndeg == 1 ) then - - value = c(0) + c(1) * ( x - b(1) ) - - else - - skp2 = c(ndeg) - skp1 = c(ndeg-1) + ( x - b(ndeg) ) * skp2 - - do k = ndeg-2, 0, -1 - sk = c(k) + ( x - b(k+1) ) * skp1 - d(k+2) * skp2 - skp2 = skp1 - skp1 = sk - end do - - value = sk - - end if - - return -end -subroutine least_set ( point_num, x, f, w, nterms, b, c, d ) - -!*****************************************************************************80 -! -!! LEAST_SET defines a least squares polynomial for given data. -! -! Discussion: -! -! This routine is based on ORTPOL by Conte and deBoor. -! -! The polynomial may be evaluated at any point X by calling LEAST_VAL. -! -! Thanks to Andrew Telford for pointing out a mistake in the form of -! the check that there are enough unique data points, 25 June 2008. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! Original FORTRAN77 version by Samuel Conte, Carl deBoor. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! Samuel Conte, Carl deBoor, -! Elementary Numerical Analysis, -! Second Edition, -! McGraw Hill, 1972, -! ISBN: 07-012446-4, -! LC: QA297.C65. -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of data values. -! -! Input, real ( kind = 8 ) X(POINT_NUM), the abscissas of the data points. -! At least NTERMS of the values in X must be distinct. -! -! Input, real ( kind = 8 ) F(POINT_NUM), the data values at the points X(*). -! -! Input, real ( kind = 8 ) W(POINT_NUM), the weights associated with -! the data points. Each entry of W should be positive. -! -! Input, integer ( kind = 4 ) NTERMS, the number of terms to use in the -! approximating polynomial. NTERMS must be at least 1. -! The degree of the polynomial is NTERMS-1. -! -! Output, real ( kind = 8 ) B(NTERMS), C(NTERMS), D(NTERMS), are quantities -! defining the least squares polynomial for the input data, -! which will be needed to evaluate the polynomial. -! - implicit none - - integer ( kind = 4 ) point_num - integer ( kind = 4 ) nterms - - real ( kind = 8 ) b(nterms) - real ( kind = 8 ) c(nterms) - real ( kind = 8 ) d(nterms) - real ( kind = 8 ) f(point_num) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - real ( kind = 8 ) p - real ( kind = 8 ) pj(point_num) - real ( kind = 8 ) pjm1(point_num) - real ( kind = 8 ) s(nterms) - real ( kind = 8 ), parameter :: tol = 0.0D+00 - integer ( kind = 4 ) unique_num - real ( kind = 8 ) w(point_num) - real ( kind = 8 ) x(point_num) -! -! Make sure at least NTERMS X values are unique. -! - call r8vec_unique_count ( point_num, x, tol, unique_num ) - - if ( unique_num < nterms ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'LEAST_SET - Fatal error!' - write ( *, '(a)' ) ' The number of distinct X values must be' - write ( *, '(a,i8)') ' at least NTERMS = ', nterms - write ( *, '(a,i8)' ) ' but the input data has only ', unique_num - write ( *, '(a)' ) ' distinct entries.' - return - end if -! -! Make sure all W entries are positive. -! - do i = 1, point_num - if ( w(i) <= 0.0D+00 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'LEAST_SET - Fatal error!' - write ( *, '(a)' ) ' All weights W must be positive,' - write ( *, '(a,i8)' ) ' but weight ', i - write ( *, '(a,g14.6)' ) ' is ', w(i) - return - end if - end do -! -! Start inner product summations at zero. -! - b(1:nterms) = 0.0D+00 - c(1:nterms) = 0.0D+00 - d(1:nterms) = 0.0D+00 - s(1:nterms) = 0.0D+00 -! -! Set the values of P(-1,X) and P(0,X) at all data points. -! - pjm1(1:point_num) = 0.0D+00 - pj(1:point_num) = 1.0D+00 -! -! Now compute the value of P(J,X(I)) as -! -! P(J,X(I)) = ( X(I) - B(J) ) * P(J-1,X(I)) - C(J) * P(J-2,X(I)) -! -! where -! -! S(J) = < P(J,X), P(J,X) > -! B(J) = < x*P(J,X), P(J,X) > / < P(J,X), P(J,X) > -! C(J) = S(J) / S(J-1) -! -! and the least squares coefficients are -! -! D(J) = < F(X), P(J,X) > / < P(J,X), P(J,X) > -! - do j = 1, nterms - - d(j) = d(j) + sum ( w(1:point_num) * f(1:point_num) * pj(1:point_num) ) - b(j) = b(j) + sum ( w(1:point_num) * x(1:point_num) * pj(1:point_num)**2 ) - s(j) = s(j) + sum ( w(1:point_num) * pj(1:point_num)**2 ) - - d(j) = d(j) / s(j) - - if ( j == nterms ) then - c(j) = 0.0D+00 - return - end if - - b(j) = b(j) / s(j) - - if ( j == 1 ) then - c(j) = 0.0D+00 - else - c(j) = s(j) / s(j-1) - end if - - do i = 1, point_num - p = pj(i) - pj(i) = ( x(i) - b(j) ) * pj(i) - c(j) * pjm1(i) - pjm1(i) = p - end do - - end do - - return -end -subroutine least_val ( nterms, b, c, d, x, px ) - -!*****************************************************************************80 -! -!! LEAST_VAL evaluates a least squares polynomial defined by LEAST_SET. -! -! Discussion: -! -! The least squares polynomial is assumed to be defined as a sum -! -! P(X) = sum ( 1 <= I <= NTERMS ) D(I) * P(I-1,X) -! -! where the orthogonal basis polynomials P(I,X) satisfy the following -! three term recurrence: -! -! P(-1,X) = 0 -! P(0,X) = 1 -! P(I,X) = ( X - B(I-1) ) * P(I-1,X) - C(I-1) * P(I-2,X) -! -! Therefore, the least squares polynomial can be evaluated as follows: -! -! If NTERMS is 1, then the value of P(X) is D(1) * P(0,X) = D(1). -! -! Otherwise, P(X) is defined as the sum of NTERMS > 1 terms. We can -! reduce the number of terms by 1, because the polynomial P(NTERMS,X) -! can be rewritten as a sum of polynomials; Therefore, P(NTERMS,X) -! can be eliminated from the sum, and its coefficient merged in with -! those of other polynomials. Repeat this process for P(NTERMS-1,X) -! and so on until a single term remains. -! P(NTERMS,X) of P(NTERMS-1,X) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 May 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Samuel Conte, Carl deBoor, -! Elementary Numerical Analysis, -! Second Edition, -! McGraw Hill, 1972, -! ISBN: 07-012446-4, -! LC: QA297.C65. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NTERMS, the number of terms in the least -! squares polynomial. NTERMS must be at least 1. The input value of NTERMS -! may be reduced from the value given to LEAST_SET. This will -! evaluate the least squares polynomial of the lower degree specified. -! -! Input, real ( kind = 8 ) B(NTERMS), C(NTERMS), D(NTERMS), the information -! computed by LEAST_SET. -! -! Input, real ( kind = 8 ) X, the point at which the least squares polynomial -! is to be evaluated. -! -! Output, real ( kind = 8 ) PX, the value of the least squares -! polynomial at X. -! - implicit none - - integer ( kind = 4 ) nterms - - real ( kind = 8 ) b(nterms) - real ( kind = 8 ) c(nterms) - real ( kind = 8 ) d(nterms) - integer ( kind = 4 ) i - real ( kind = 8 ) prev - real ( kind = 8 ) prev2 - real ( kind = 8 ) px - real ( kind = 8 ) x - - px = d(nterms) - prev = 0.0D+00 - - do i = nterms - 1, 1, -1 - - prev2 = prev - prev = px - - if ( i == nterms-1 ) then - px = d(i) + ( x - b(i) ) * prev - else - px = d(i) + ( x - b(i) ) * prev - c(i+1) * prev2 - end if - - end do - - return -end -subroutine least_val2 ( nterms, b, c, d, x, px, pxp ) - -!*****************************************************************************80 -! -!! LEAST_VAL2 evaluates a least squares polynomial defined by LEAST_SET. -! -! Discussion: -! -! This routine also computes the derivative of the polynomial. -! -! The least squares polynomial is assumed to be defined as a sum -! -! P(X) = sum ( 1 <= I <= NTERMS ) D(I) * P(I-1,X) -! -! where the orthogonal basis polynomials P(I,X) satisfy the following -! three term recurrence: -! -! P(-1,X) = 0 -! P(0,X) = 1 -! P(I,X) = ( X - B(I-1) ) * P(I-1,X) - C(I-1) * P(I-2,X) -! -! Therefore, the least squares polynomial can be evaluated as follows: -! -! If NTERMS is 1, then the value of P(X) is D(1) * P(0,X) = D(1). -! -! Otherwise, P(X) is defined as the sum of NTERMS > 1 terms. We can -! reduce the number of terms by 1, because the polynomial P(NTERMS,X) -! can be rewritten as a sum of polynomials; Therefore, P(NTERMS,X) -! can be eliminated from the sum, and its coefficient merged in with -! those of other polynomials. Repeat this process for P(NTERMS-1,X) -! and so on until a single term remains. -! P(NTERMS,X) of P(NTERMS-1,X) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NTERMS, the number of terms in the least -! squares polynomial. NTERMS must be at least 1. The value of NTERMS -! may be reduced from the value given to LEAST_SET. -! This will cause LEAST_VAL to evaluate the least squares polynomial -! of the lower degree specified. -! -! Input, real ( kind = 8 ) B(NTERMS), C(NTERMS), D(NTERMS), the information -! computed by LEAST_SET. -! -! Input, real ( kind = 8 ) X, the point at which the least squares polynomial -! is to be evaluated. -! -! Output, real ( kind = 8 ) PX, PXP, the value and derivative of the least -! squares polynomial at X. -! - implicit none - - integer ( kind = 4 ) nterms - - real ( kind = 8 ) b(nterms) - real ( kind = 8 ) c(nterms) - real ( kind = 8 ) d(nterms) - integer ( kind = 4 ) i - real ( kind = 8 ) px - real ( kind = 8 ) pxm1 - real ( kind = 8 ) pxm2 - real ( kind = 8 ) pxp - real ( kind = 8 ) pxpm1 - real ( kind = 8 ) pxpm2 - real ( kind = 8 ) x - - px = d(nterms) - pxp = 0.0D+00 - pxm1 = 0.0D+00 - pxpm1 = 0.0D+00 - - do i = nterms - 1, 1, -1 - - pxm2 = pxm1 - pxpm2 = pxpm1 - pxm1 = px - pxpm1 = pxp - - if ( i == nterms - 1 ) then - px = d(i) + ( x - b(i) ) * pxm1 - pxp = pxm1 + ( x - b(i) ) * pxpm1 - else - px = d(i) + ( x - b(i) ) * pxm1 - c(i+1) * pxm2 - pxp = pxm1 + ( x - b(i) ) * pxpm1 - c(i+1) * pxpm2 - end if - - end do - - return -end -subroutine parabola_val2 ( dim_num, ndata, tdata, ydata, left, tval, yval ) - -!*****************************************************************************80 -! -!! PARABOLA_VAL2 evaluates a parabolic interpolant through tabular data. -! -! Discussion: -! -! This routine is a utility routine used by OVERHAUSER_SPLINE_VAL. -! It constructs the parabolic interpolant through the data in -! 3 consecutive entries of a table and evaluates this interpolant -! at a given abscissa value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of a single data point. -! DIM_NUM must be at least 1. -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! NDATA must be at least 3. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data -! points. The values in TDATA must be in strictly ascending order. -! -! Input, real ( kind = 8 ) YDATA(DIM_NUM,NDATA), the data points -! corresponding to the abscissas. -! -! Input, integer ( kind = 4 ) LEFT, the location of the first of the three -! consecutive data points through which the parabolic interpolant -! must pass. 1 <= LEFT <= NDATA - 2. -! -! Input, real ( kind = 8 ) TVAL, the value of T at which the parabolic -! interpolant is to be evaluated. Normally, TDATA(1) <= TVAL <= T(NDATA), -! and the data will be interpolated. For TVAL outside this range, -! extrapolation will be used. -! -! Output, real ( kind = 8 ) YVAL(DIM_NUM), the value of the parabolic -! interpolant at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - integer ( kind = 4 ) dim_num - - real ( kind = 8 ) dif1 - real ( kind = 8 ) dif2 - integer ( kind = 4 ) i - integer ( kind = 4 ) left - real ( kind = 8 ) t1 - real ( kind = 8 ) t2 - real ( kind = 8 ) t3 - real ( kind = 8 ) tval - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) ydata(dim_num,ndata) - real ( kind = 8 ) y1 - real ( kind = 8 ) y2 - real ( kind = 8 ) y3 - real ( kind = 8 ) yval(dim_num) -! -! Check. -! - if ( left < 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'PARABOLA_VAL2 - Fatal error!' - write ( *, '(a)' ) ' LEFT < 1.' - write ( *, '(a,i8)' ) ' LEFT = ', left - stop 1 - end if - - if ( ndata-2 < left ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'PARABOLA_VAL2 - Fatal error!' - write ( *, '(a)' ) ' NDATA-2 < LEFT.' - write ( *, '(a,i8)' ) ' NDATA = ', ndata - write ( *, '(a,i8)' ) ' LEFT = ', left - stop 1 - end if - - if ( dim_num < 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'PARABOLA_VAL2 - Fatal error!' - write ( *, '(a)' ) ' DIM_NUM < 1.' - stop 1 - end if -! -! Copy out the three abscissas. -! - t1 = tdata(left) - t2 = tdata(left+1) - t3 = tdata(left+2) - - if ( t2 <= t1 .or. t3 <= t2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'PARABOLA_VAL2 - Fatal error!' - write ( *, '(a)' ) ' T2 <= T1 or T3 <= T2.' - stop 1 - end if -! -! Construct and evaluate a parabolic interpolant for the data -! in each dimension. -! - do i = 1, dim_num - - y1 = ydata(i,left) - y2 = ydata(i,left+1) - y3 = ydata(i,left+2) - - dif1 = ( y2 - y1 ) / ( t2 - t1 ) - dif2 = ( ( y3 - y1 ) / ( t3 - t1 ) & - - ( y2 - y1 ) / ( t2 - t1 ) ) / ( t3 - t2 ) - - yval(i) = y1 + ( tval - t1 ) * ( dif1 + ( tval - t2 ) * dif2 ) - - end do - - return -end -function pchst ( arg1, arg2 ) - -!*****************************************************************************80 -! -!! PCHST: PCHIP sign-testing routine. -! -! Discussion: -! -! This routine essentially computes the sign of ARG1 * ARG2. -! -! The object is to do this without multiplying ARG1 * ARG2, to avoid -! possible over/underflow problems. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! Original FORTRAN77 version by Fred Fritsch. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Fred Fritsch, Ralph Carlson, -! Monotone Piecewise Cubic Interpolation, -! SIAM Journal on Numerical Analysis, -! Volume 17, Number 2, April 1980, pages 238-246. -! -! Parameters: -! -! Input, real ( kind = 8 ) ARG1, ARG2, two values to check. -! -! Output, real ( kind = 8 ) PCHST, -! -1.0, if ARG1 and ARG2 are of opposite sign. -! 0.0, if either argument is zero. -! +1.0, if ARG1 and ARG2 are of the same sign. -! - implicit none - - real ( kind = 8 ) arg1 - real ( kind = 8 ) arg2 - real ( kind = 8 ) pchst - - pchst = sign ( 1.0D+00, arg1 ) * sign ( 1.0D+00, arg2 ) - - if ( arg1 == 0.0D+00 .or. arg2 == 0.0D+00 ) then - pchst = 0.0D+00 - end if - - return -end -subroutine r8_swap ( x, y ) - -!*****************************************************************************80 -! -!! R8_SWAP swaps two real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 May 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and -! Y have been interchanged. -! - implicit none - - real ( kind = 8 ) x - real ( kind = 8 ) y - real ( kind = 8 ) z - - z = x - x = y - y = z - - return -end -function r8_uniform_01 ( seed ) - -!*****************************************************************************80 -! -!! R8_UNIFORM_01 is a portable pseudorandom number generator. -! -! Discussion: -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2**31 - 1 ) -! unif = seed / ( 2**31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 August 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should -! NOT be 0. (Otherwise, the output values of SEED and UNIFORM will be zero.) -! On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. -! - implicit none - - integer ( kind = 4 ) k - integer ( kind = 4 ) seed - real ( kind = 8 ) r8_uniform_01 - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + 2147483647 - end if -! -! Although SEED can be represented exactly as a 32 bit integer, -! it generally cannot be represented exactly as a 32 bit real number! -! - r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875E-10 - - return -end -subroutine r83_mxv ( n, a, x, b ) - -!*****************************************************************************80 -! -!! R83_MXV multiplies an R83 matrix times a vector. -! -! Discussion: -! -! The R83 storage format is used for a tridiagonal matrix. -! The superdiagonal is stored in entries (1,2:N), the diagonal in -! entries (2,1:N), and the subdiagonal in (3,1:N-1). Thus, the -! original matrix is "collapsed" vertically into the array. -! -! Example: -! -! Here is how an R83 matrix of order 5 would be stored: -! -! * A12 A23 A34 A45 -! A11 A22 A33 A44 A55 -! A21 A32 A43 A54 * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 November 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the linear system. -! -! Input, real ( kind = 8 ) A(3,N), the R83 matrix. -! -! Input, real ( kind = 8 ) X(N), the vector to be multiplied by A. -! -! Output, real ( kind = 8 ) B(N), the product A * x. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(3,n) - real ( kind = 8 ) b(n) - real ( kind = 8 ) x(n) - - b(1:n) = a(2,1:n) * x(1:n) - b(1:n-1) = b(1:n-1) + a(1,2:n) * x(2:n) - b(2:n) = b(2:n) + a(3,1:n-1) * x(1:n-1) - - return -end -subroutine r83_np_fs ( n, a, b, x ) - -!*****************************************************************************80 -! -!! R83_NP_FS factors and solves an R83 system. -! -! Discussion: -! -! The R83 storage format is used for a tridiagonal matrix. -! The superdiagonal is stored in entries (1,2:N), the diagonal in -! entries (2,1:N), and the subdiagonal in (3,1:N-1). Thus, the -! original matrix is "collapsed" vertically into the array. -! -! This algorithm requires that each diagonal entry be nonzero. -! It does not use pivoting, and so can fail on systems that -! are actually nonsingular. -! -! Here is how an R83 matrix of order 5 would be stored: -! -! * A12 A23 A34 A45 -! A11 A22 A33 A44 A55 -! A21 A32 A43 A54 * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 November 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the linear system. -! -! Input/output, real ( kind = 8 ) A(3,N). -! On input, the tridiagonal matrix. -! On output, the data in these vectors has been overwritten -! by factorization information. -! -! Input, real ( kind = 8 ) B(N), the right hand side of the linear system. -! -! Output, real ( kind = 8 ) X(N), the solution of the linear system. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(3,n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - real ( kind = 8 ) x(n) - real ( kind = 8 ) xmult -! -! The diagonal entries can't be zero. -! - do i = 1, n - if ( a(2,i) == 0.0D+00 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R83_NP_FS - Fatal error!' - write ( *, '(a,i8,a)' ) ' A(2,', i, ') = 0.' - return - end if - end do - - x(1:n) = b(1:n) - - do i = 2, n - xmult = a(3,i-1) / a(2,i-1) - a(2,i) = a(2,i) - xmult * a(1,i) - x(i) = x(i) - xmult * x(i-1) - end do - - x(n) = x(n) / a(2,n) - do i = n - 1, 1, -1 - x(i) = ( x(i) - a(1,i+1) * x(i+1) ) / a(2,i) - end do - - return -end -subroutine r83_uniform ( n, seed, a ) - -!*****************************************************************************80 -! -!! R83_UNIFORM randomizes an R83 matrix. -! -! Discussion: -! -! The R83 storage format is used for a tridiagonal matrix. -! The superdiagonal is stored in entries (1,2:N), the diagonal in -! entries (2,1:N), and the subdiagonal in (3,1:N-1). Thus, the -! original matrix is "collapsed" vertically into the array. -! -! Here is how an R83 matrix of order 5 would be stored: -! -! * A12 A23 A34 A45 -! A11 A22 A33 A44 A55 -! A21 A32 A43 A54 * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the linear system. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) A(3,N), the R83 matrix. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(3,n) - integer ( kind = 4 ) seed - - a(1,1) = 0.0D+00 - call r8vec_uniform_01 ( n-1, seed, a(1,2:n) ) - - call r8vec_uniform_01 ( n, seed, a(2,1:n) ) - - call r8vec_uniform_01 ( n-1, seed, a(3,1:n-1) ) - a(3,n) = 0.0D+00 - - return -end -subroutine r85_np_fs ( n, a, b, x ) - -!*****************************************************************************80 -! -!! R85_NP_FS factors and solves an R85 linear system. -! -! Discussion: -! -! The R85 storage format represents a pentadiagonal matrix as a 5 -! by N array, in which each row corresponds to a diagonal, and -! column locations are preserved. Thus, the original matrix is -! "collapsed" vertically into the array. -! -! The factorization algorithm requires that each diagonal entry be nonzero. -! -! No pivoting is performed, and therefore the algorithm may fail -! in simple cases where the matrix is not singular. -! -! Example: -! -! Here is how an R85 matrix of order 6 would be stored: -! -! * * A13 A24 A35 A46 -! * A12 A23 A34 A45 A56 -! A11 A22 A33 A44 A55 A66 -! A21 A32 A43 A54 A65 * -! A31 A42 A53 A64 * * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 September 2003 -! -! Author: -! -! Original FORTRAN77 version by Ward Cheney, David Kincaid. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Ward Cheney, David Kincaid, -! Numerical Mathematics and Computing, -! Brooks-Cole Publishing, 2004, -! ISBN: 0534201121. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the linear system. -! -! Input/output, real ( kind = 8 ) A(5,N), -! On input, the pentadiagonal matrix. -! On output, the data has been overwritten by factorization information. -! -! Input/output, real ( kind = 8 ) B(N). -! On input, B contains the right hand side of the linear system. -! On output, B has been overwritten by factorization information. -! -! Output, real ( kind = 8 ) X(N), the solution of the linear system. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(5,n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - real ( kind = 8 ) x(n) - real ( kind = 8 ) xmult - - do i = 1, n - if ( a(3,i) == 0.0D+00 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R85_NP_FS - Fatal error!' - write ( *, '(a,i8,a)' ) ' A(3,', i, ') = 0.' - stop 1 - end if - end do - - do i = 2, n - 1 - - xmult = a(2,i) / a(3,i-1) - a(3,i) = a(3,i) - xmult * a(4,i-1) - a(4,i) = a(4,i) - xmult * a(5,i-1) - - b(i) = b(i) - xmult * b(i-1) - - xmult = a(1,i+1) / a(3,i-1) - a(2,i+1) = a(2,i+1) - xmult * a(4,i-1) - a(3,i+1) = a(3,i+1) - xmult * a(5,i-1) - - b(i+1) = b(i+1) - xmult * b(i-1) - - end do - - call r8vec_print ( n, b, ' Bpart1: ') - - xmult = a(2,n) / a(3,n-1) - a(3,n) = a(3,n) - xmult * a(4,n-1) - - x(n) = ( b(n) - xmult * b(n-1) ) / a(3,n) - x(n-1) = ( b(n-1) - a(4,n-1) * x(n) ) / a(3,n-1) - - do i = n - 2, 1, -1 - x(i) = ( b(i) - a(4,i) * x(i+1) - a(5,i) * x(i+2) ) / a(3,i) - end do - - return -end -subroutine r85_print ( n, a, title ) - -!*****************************************************************************80 -! -!! R85_PRINT prints an R85 matrix. -! -! Discussion: -! -! The R85 storage format represents a pentadiagonal matrix as a 5 -! by N array, in which each row corresponds to a diagonal, and -! column locations are preserved. Thus, the original matrix is -! "collapsed" vertically into the array. -! -! Example: -! -! Here is how an R85 matrix of order 6 would be stored: -! -! * * A13 A24 A35 A46 -! * A12 A23 A34 A45 A56 -! A11 A22 A33 A44 A55 A66 -! A21 A32 A43 A54 A65 * -! A31 A42 A53 A64 * * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input, real ( kind = 8 ) A(5,N), the matrix. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(5,n) - character ( len = * ) title - - call r85_print_some ( n, a, 1, 1, n, n, title ) - - return -end -subroutine r85_print_some ( n, a, ilo, jlo, ihi, jhi, title ) - -!*****************************************************************************80 -! -!! R85_PRINT_SOME prints some of an R85 matrix. -! -! Discussion: -! -! The R85 storage format represents a pentadiagonal matrix as a 5 -! by N array, in which each row corresponds to a diagonal, and -! column locations are preserved. Thus, the original matrix is -! "collapsed" vertically into the array. -! -! Example: -! -! Here is how an R85 matrix of order 6 would be stored: -! -! * * A13 A24 A35 A46 -! * A12 A23 A34 A45 A56 -! A11 A22 A33 A44 A55 A66 -! A21 A32 A43 A54 A65 * -! A31 A42 A53 A64 * * -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 January 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input, real ( kind = 8 ) A(5,N), the matrix. -! -! Input, integer ( kind = 4 ) ILO, JLO, IHI, JHI, the first row and -! column, and the last row and column, to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer ( kind = 4 ), parameter :: incx = 5 - integer ( kind = 4 ) n - - real ( kind = 8 ) a(5,n) - character ( len = 14 ) ctemp(incx) - integer ( kind = 4 ) i - integer ( kind = 4 ) i2hi - integer ( kind = 4 ) i2lo - integer ( kind = 4 ) ihi - integer ( kind = 4 ) ilo - integer ( kind = 4 ) inc - integer ( kind = 4 ) j - integer ( kind = 4 ) j2 - integer ( kind = 4 ) j2hi - integer ( kind = 4 ) j2lo - integer ( kind = 4 ) jhi - integer ( kind = 4 ) jlo - character ( len = * ) title - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) trim ( title ) -! -! Print the columns of the matrix, in strips of 5. -! - do j2lo = jlo, jhi, incx - - j2hi = j2lo + incx - 1 - j2hi = min ( j2hi, n ) - j2hi = min ( j2hi, jhi ) - - inc = j2hi + 1 - j2lo - - write ( *, '(a)' ) ' ' - - do j = j2lo, j2hi - j2 = j + 1 - j2lo - write ( ctemp(j2), '(i7,7x)' ) j - end do - - write ( *, '('' Col: '',5a14)' ) ( ctemp(j2), j2 = 1, inc ) - write ( *, '(a)' ) ' Row' - write ( *, '(a)' ) ' ---' -! -! Determine the range of the rows in this strip. -! - i2lo = max ( ilo, 1 ) - i2lo = max ( i2lo, j2lo - 2 ) - - i2hi = min ( ihi, n ) - i2hi = min ( i2hi, j2hi + 2 ) - - do i = i2lo, i2hi -! -! Print out (up to) 5 entries in row I, that lie in the current strip. -! - do j2 = 1, inc - - j = j2lo - 1 + j2 - - if ( 2 < i-j .or. 2 < j-i ) then - ctemp(j2) = ' ' - else if ( j == i+2 ) then - write ( ctemp(j2), '(g14.6)' ) a(1,j) - else if ( j == i+1 ) then - write ( ctemp(j2), '(g14.6)' ) a(2,j) - else if ( j == i ) then - write ( ctemp(j2), '(g14.6)' ) a(3,j) - else if ( j == i-1 ) then - write ( ctemp(j2), '(g14.6)' ) a(4,j) - else if ( j == i-2 ) then - write ( ctemp(j2), '(g14.6)' ) a(5,j) - end if - - end do - - write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j2), j2 = 1, inc ) - - end do - - end do - - return -end -subroutine r8ge_fs ( n, a, b, info ) - -!*****************************************************************************80 -! -!! R8GE_FS factors and solves an R8GE system. -! -! Discussion: -! -! The R8GE storage format is used for a general M by N matrix. A storage -! space is made for each entry. The two dimensional logical -! array can be thought of as a vector of M*N entries, starting with -! the M entries in the column 1, then the M entries in column 2 -! and so on. Considered as a vector, the entry A(I,J) is then stored -! in vector location I+(J-1)*M. -! -! R8GE storage is used by LINPACK and LAPACK. -! -! R8GE_FS does not save the LU factors of the matrix, and hence cannot -! be used to efficiently solve multiple linear systems, or even to -! factor A at one time, and solve a single linear system at a later time. -! -! R8GE_FS uses partial pivoting, but no pivot vector is required. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input/output, real ( kind = 8 ) A(N,N). -! On input, A is the coefficient matrix of the linear system. -! On output, A is in unit upper triangular form, and -! represents the U factor of an LU factorization of the -! original coefficient matrix. -! -! Input/output, real ( kind = 8 ) B(N). -! On input, B is the right hand side of the linear system. -! On output, B is the solution of the linear system. -! -! Output, integer ( kind = 4 ) INFO, singularity flag. -! 0, no singularity detected. -! nonzero, the factorization failed on the INFO-th step. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n,n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) info - integer ( kind = 4 ) ipiv - integer ( kind = 4 ) j - integer ( kind = 4 ) jcol - real ( kind = 8 ) piv - real ( kind = 8 ) row(n) - real ( kind = 8 ) temp - - info = 0 - - do jcol = 1, n -! -! Find the maximum element in column I. -! - piv = abs ( a(jcol,jcol) ) - ipiv = jcol - do i = jcol + 1, n - if ( piv < abs ( a(i,jcol) ) ) then - piv = abs ( a(i,jcol) ) - ipiv = i - end if - end do - - if ( piv == 0.0D+00 ) then - info = jcol - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8GE_FS - Fatal error!' - write ( *, '(a,i8)' ) ' Zero pivot on step ', info - stop 1 - end if -! -! Switch rows JCOL and IPIV, and B. -! - if ( jcol /= ipiv ) then - - row(1:n) = a(jcol,1:n) - a(jcol,1:n) = a(ipiv,1:n) - a(ipiv,1:n) = row(1:n) - - temp = b(jcol) - b(jcol) = b(ipiv) - b(ipiv) = temp - - end if -! -! Scale the pivot row. -! - a(jcol,jcol+1:n) = a(jcol,jcol+1:n) / a(jcol,jcol) - b(jcol) = b(jcol) / a(jcol,jcol) - a(jcol,jcol) = 1.0D+00 -! -! Use the pivot row to eliminate lower entries in that column. -! - do i = jcol + 1, n - if ( a(i,jcol) /= 0.0D+00 ) then - temp = - a(i,jcol) - a(i,jcol) = 0.0D+00 - a(i,jcol+1:n) = a(i,jcol+1:n) + temp * a(jcol,jcol+1:n) - b(i) = b(i) + temp * b(jcol) - end if - end do - - end do -! -! Back solve. -! - do jcol = n, 2, -1 - b(1:jcol-1) = b(1:jcol-1) - a(1:jcol-1,jcol) * b(jcol) - end do - - return -end -subroutine r8vec_bracket ( n, x, xval, left, right ) - -!*****************************************************************************80 -! -!! R8VEC_BRACKET searches a sorted R8VEC for successive brackets of a value. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! If the values in the vector are thought of as defining intervals -! on the real line, then this routine searches for the interval -! nearest to or containing the given value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, length of input array. -! -! Input, real ( kind = 8 ) X(N), an array sorted into ascending order. -! -! Input, real ( kind = 8 ) XVAL, a value to be bracketed. -! -! Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search. -! Either: -! XVAL < X(1), when LEFT = 1, RIGHT = 2; -! X(N) < XVAL, when LEFT = N-1, RIGHT = N; -! or -! X(LEFT) <= XVAL <= X(RIGHT). -! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) i - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) x(n) - real ( kind = 8 ) xval - - do i = 2, n - 1 - - if ( xval < x(i) ) then - left = i - 1 - right = i - return - end if - - end do - - left = n - 1 - right = n - - return -end -subroutine r8vec_bracket3 ( n, t, tval, left ) - -!*****************************************************************************80 -! -!! R8VEC_BRACKET3 finds the interval containing or nearest a given value. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! The routine always returns the index LEFT of the sorted array -! T with the property that either -! * T is contained in the interval [ T(LEFT), T(LEFT+1) ], or -! * T < T(LEFT) = T(1), or -! * T > T(LEFT+1) = T(N). -! -! The routine is useful for interpolation problems, where -! the abscissa must be located within an interval of data -! abscissas for interpolation, or the "nearest" interval -! to the (extreme) abscissa must be found so that extrapolation -! can be carried out. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, length of the input array. -! -! Input, real ( kind = 8 ) T(N), an array sorted into ascending order. -! -! Input, real ( kind = 8 ) TVAL, a value to be bracketed by entries of T. -! -! Input/output, integer ( kind = 4 ) LEFT. -! -! On input, if 1 <= LEFT <= N-1, LEFT is taken as a suggestion for the -! interval [ T(LEFT), T(LEFT+1) ] in which TVAL lies. This interval -! is searched first, followed by the appropriate interval to the left -! or right. After that, a binary search is used. -! -! On output, LEFT is set so that the interval [ T(LEFT), T(LEFT+1) ] -! is the closest to TVAL; it either contains TVAL, or else TVAL -! lies outside the interval [ T(1), T(N) ]. -! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) high - integer ( kind = 4 ) left - integer ( kind = 4 ) low - integer ( kind = 4 ) mid - real ( kind = 8 ) t(n) - real ( kind = 8 ) tval -! -! Check the input data. -! - if ( n < 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8VEC_BRACKET3 - Fatal error!' - write ( *, '(a)' ) ' N must be at least 2.' - stop 1 - end if -! -! If LEFT is not between 1 and N-1, set it to the middle value. -! - if ( left < 1 .or. n - 1 < left ) then - left = ( n + 1 ) / 2 - end if -! -! CASE 1: TVAL < T(LEFT): -! Search for TVAL in [T(I), T(I+1)] for intervals I = 1 to LEFT-1. -! - if ( tval < t(left) ) then - - if ( left == 1 ) then - return - else if ( left == 2 ) then - left = 1 - return - else if ( t(left-1) <= tval ) then - left = left - 1 - return - else if ( tval <= t(2) ) then - left = 1 - return - end if -! -! ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = 2 to LEFT-2. -! - low = 2 - high = left - 2 - - do - - if ( low == high ) then - left = low - return - end if - - mid = ( low + high + 1 ) / 2 - - if ( t(mid) <= tval ) then - low = mid - else - high = mid - 1 - end if - - end do -! -! CASE2: T(LEFT+1) < TVAL: -! Search for TVAL in {T(I),T(I+1)] for intervals I = LEFT+1 to N-1. -! - else if ( t(left+1) < tval ) then - - if ( left == n - 1 ) then - return - else if ( left == n - 2 ) then - left = left + 1 - return - else if ( tval <= t(left+2) ) then - left = left + 1 - return - else if ( t(n-1) <= tval ) then - left = n - 1 - return - end if -! -! ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = LEFT+2 to N-2. -! - low = left + 2 - high = n - 2 - - do - - if ( low == high ) then - left = low - return - end if - - mid = ( low + high + 1 ) / 2 - - if ( t(mid) <= tval ) then - low = mid - else - high = mid - 1 - end if - - end do -! -! CASE3: T(LEFT) <= TVAL <= T(LEFT+1): -! T is in [T(LEFT), T(LEFT+1)], as the user said it might be. -! - else - - end if - - return -end -function r8vec_distinct ( n, x ) - -!*****************************************************************************80 -! -!! R8VEC_DISTINCT is true if the entries in an R8VEC are distinct. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 September 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the vector. -! -! Input, real ( kind = 8 ) X(N), the vector to be checked. -! -! Output, logical R8VEC_DISTINCT is TRUE if all N elements of X -! are distinct. -! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) i - integer ( kind = 4 ) j - logical r8vec_distinct - real ( kind = 8 ) x(n) - - r8vec_distinct = .false. - - do i = 2, n - do j = 1, i - 1 - if ( x(i) == x(j) ) then - return - end if - end do - end do - - r8vec_distinct = .true. - - return -end -subroutine r8vec_even ( n, alo, ahi, a ) - -!*****************************************************************************80 -! -!! R8VEC_EVEN returns N real values, evenly spaced between ALO and AHI. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 February 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of values. -! -! Input, real ( kind = 8 ) ALO, AHI, the low and high values. -! -! Output, real ( kind = 8 ) A(N), N evenly spaced values. -! Normally, A(1) = ALO and A(N) = AHI. -! However, if N = 1, then A(1) = 0.5*(ALO+AHI). -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - real ( kind = 8 ) ahi - real ( kind = 8 ) alo - integer ( kind = 4 ) i - - if ( n == 1 ) then - - a(1) = 0.5D+00 * ( alo + ahi ) - - else - - do i = 1, n - a(i) = ( real ( n - i, kind = 8 ) * alo & - + real ( i - 1, kind = 8 ) * ahi ) & - / real ( n - 1, kind = 8 ) - end do - - end if - - return -end -subroutine r8vec_indicator ( n, a ) - -!*****************************************************************************80 -! -!! R8VEC_INDICATOR sets an R8VEC to the indicator vector. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 February 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of elements of A. -! -! Output, real ( kind = 8 ) A(N), the array to be initialized. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - integer ( kind = 4 ) i - - do i = 1, n - a(i) = real ( i, kind = 8 ) - end do - - return -end -subroutine r8vec_order_type ( n, a, order ) - -!*****************************************************************************80 -! -!! R8VEC_ORDER_TYPE determines the order type of an R8VEC. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! We assume the array is increasing or decreasing, and we want to -! verify that. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 July 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries of the array. -! -! Input, real ( kind = 8 ) A(N), the array to be checked. -! -! Output, integer ( kind = 4 ) ORDER, order indicator: -! -1, no discernable order; -! 0, all entries are equal; -! 1, ascending order; -! 2, strictly ascending order; -! 3, descending order; -! 4, strictly descending order. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) order -! -! Search for the first value not equal to A(1). -! - i = 1 - - do - - i = i + 1 - - if ( n < i ) then - order = 0 - return - end if - - if ( a(1) < a(i) ) then - - if ( i == 2 ) then - order = 2 - else - order = 1 - end if - - exit - - else if ( a(i) < a(1) ) then - - if ( i == 2 ) then - order = 4 - else - order = 3 - end if - - exit - - end if - - end do -! -! Now we have a "direction". Examine subsequent entries. -! - do - - i = i + 1 - if ( n < i ) then - exit - end if - - if ( order == 1 ) then - - if ( a(i) < a(i-1) ) then - order = -1 - exit - end if - - else if ( order == 2 ) then - - if ( a(i) < a(i-1) ) then - order = -1 - exit - else if ( a(i) == a(i-1) ) then - order = 1 - end if - - else if ( order == 3 ) then - - if ( a(i-1) < a(i) ) then - order = -1 - exit - end if - - else if ( order == 4 ) then - - if ( a(i-1) < a(i) ) then - order = -1 - exit - else if ( a(i) == a(i-1) ) then - order = 3 - end if - - end if - - end do - - return -end -subroutine r8vec_print ( n, a, title ) - -!*****************************************************************************80 -! -!! R8VEC_PRINT prints an R8VEC. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 December 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of components of the vector. -! -! Input, real ( kind = 8 ) A(N), the vector to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - integer ( kind = 4 ) i - character ( len = * ) title - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) trim ( title ) - write ( *, '(a)' ) ' ' - do i = 1, n - write ( *, '(i8,g14.6)' ) i, a(i) - end do - - return -end -subroutine r8vec_sort_bubble_a ( n, a ) - -!*****************************************************************************80 -! -!! R8VEC_SORT_BUBBLE_A ascending sorts an R8VEC using bubble sort. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Bubble sort is simple to program, but inefficient. It should not -! be used for large arrays. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 February 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the array. -! -! Input/output, real ( kind = 8 ) A(N). -! On input, an unsorted array. -! On output, the array has been sorted. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - - do i = 1, n-1 - do j = i+1, n - if ( a(j) < a(i) ) then - call r8_swap ( a(i), a(j) ) - end if - end do - end do - - return -end -subroutine r8vec_uniform_01 ( n, seed, r ) - -!*****************************************************************************80 -! -!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 August 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller, -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of entries in the vector. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. -! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) i - integer ( kind = 4 ) k - integer ( kind = 4 ) seed - real ( kind = 8 ) r(n) - - do i = 1, n - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + 2147483647 - end if - - r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 - - end do - - return -end -subroutine r8vec_unique_count ( n, a, tol, unique_num ) - -!*****************************************************************************80 -! -!! R8VEC_UNIQUE_COUNT counts the unique elements in an unsorted R8VEC. -! -! Discussion: -! -! An R8VEC is an array of double precision real values. -! -! Because the array is unsorted, this algorithm is O(N^2). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of elements of A. -! -! Input, real ( kind = 8 ) A(N), the unsorted array to examine. -! -! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality. -! Set it to 0.0 for the strictest test. -! -! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) j - integer ( kind = 4 ) unique_num - real ( kind = 8 ) tol - - unique_num = 0 - - do i = 1, n - - unique_num = unique_num + 1 - - do j = 1, i - 1 - - if ( abs ( a(i) - a(j) ) <= tol ) then - unique_num = unique_num - 1 - exit - end if - - end do - - end do - - return -end -subroutine spline_b_val ( ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_B_VAL evaluates a cubic B spline approximant. -! -! Discussion: -! -! The cubic B spline will approximate the data, but is not -! designed to interpolate it. -! -! In effect, two "phantom" data values are appended to the data, -! so that the spline will interpolate the first and last data values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data values. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data. -! -! Input, real ( kind = 8 ) YDATA(NDATA), the data values. -! -! Input, real ( kind = 8 ) TVAL, a point at which the spline is -! to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the function at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) bval - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) u - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval -! -! Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the 5 nonzero B spline basis functions in the interval, -! weighted by their corresponding data values. -! - u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) ) - yval = 0.0D+00 -! -! B function associated with node LEFT - 1, (or "phantom node"), -! evaluated in its 4th interval. -! - bval = ( ( ( - 1.0D+00 & - * u + 3.0D+00 ) & - * u - 3.0D+00 ) & - * u + 1.0D+00 ) / 6.0D+00 - - if ( 0 < left-1 ) then - yval = yval + ydata(left-1) * bval - else - yval = yval + ( 2.0D+00 * ydata(1) - ydata(2) ) * bval - end if -! -! B function associated with node LEFT, -! evaluated in its third interval. -! - bval = ( ( ( 3.0D+00 & - * u - 6.0D+00 ) & - * u + 0.0D+00 ) & - * u + 4.0D+00 ) / 6.0D+00 - - yval = yval + ydata(left) * bval -! -! B function associated with node RIGHT, -! evaluated in its second interval. -! - bval = ( ( ( - 3.0D+00 & - * u + 3.0D+00 ) & - * u + 3.0D+00 ) & - * u + 1.0D+00 ) / 6.0D+00 - - yval = yval + ydata(right) * bval -! -! B function associated with node RIGHT+1, (or "phantom node"), -! evaluated in its first interval. -! - bval = u**3 / 6.0D+00 - - if ( right+1 <= ndata ) then - yval = yval + ydata(right+1) * bval - else - yval = yval + ( 2.0D+00 * ydata(ndata) - ydata(ndata-1) ) * bval - end if - - return -end -subroutine spline_beta_val ( beta1, beta2, ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_BETA_VAL evaluates a cubic beta spline approximant. -! -! Discussion: -! -! The cubic beta spline will approximate the data, but is not -! designed to interpolate it. -! -! If BETA1 = 1 and BETA2 = 0, the cubic beta spline will be the -! same as the cubic B spline approximant. -! -! With BETA1 = 1 and BETA2 large, the beta spline becomes more like -! a linear spline. -! -! In effect, two "phantom" data values are appended to the data, -! so that the spline will interpolate the first and last data values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) BETA1, the skew or bias parameter. -! BETA1 = 1 for no skew or bias. -! -! Input, real ( kind = 8 ) BETA2, the tension parameter. -! BETA2 = 0 for no tension. -! -! Input, integer ( kind = 4 ) NDATA, the number of data values. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data. -! -! Input, real ( kind = 8 ) YDATA(NDATA), the data values. -! -! Input, real ( kind = 8 ) TVAL, a point at which the spline is -! to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the function at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) beta1 - real ( kind = 8 ) beta2 - real ( kind = 8 ) bval - real ( kind = 8 ) c - real ( kind = 8 ) d - real ( kind = 8 ) delta - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) u - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval -! -! Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the 5 nonzero beta spline basis functions in the interval, -! weighted by their corresponding data values. -! - u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) ) - - delta = ( ( 2.0D+00 & - * beta1 + 4.0D+00 ) & - * beta1 + 4.0D+00 ) & - * beta1 + 2.0D+00 + beta2 - - yval = 0.0D+00 -! -! Beta function associated with node LEFT - 1, (or "phantom node"), -! evaluated in its 4th interval. -! - bval = 2.0D+00 * ( beta1 * ( 1.0D+00 - u ) )**3 / delta - - if ( 0 < left-1 ) then - yval = yval + ydata(left-1) * bval - else - yval = yval + ( 2.0D+00 * ydata(1) - ydata(2) ) * bval - end if -! -! Beta function associated with node LEFT, -! evaluated in its third interval. -! - a = beta2 + ( 4.0D+00 + 4.0D+00 * beta1 ) * beta1 - - b = - 6.0D+00 * beta1 * ( 1.0D+00 - beta1 ) * ( 1.0D+00 + beta1 ) - - c = ( ( - 6.0D+00 & - * beta1 - 6.0D+00 ) & - * beta1 + 0.0D+00 ) & - * beta1 - 3.0D+00 * beta2 - - d = ( ( + 2.0D+00 & - * beta1 + 2.0D+00 ) & - * beta1 + 2.0D+00 ) & - * beta1 + 2.0D+00 * beta2 - - bval = ( a + u * ( b + u * ( c + u * d ) ) ) / delta - - yval = yval + ydata(left) * bval -! -! Beta function associated with node RIGHT, -! evaluated in its second interval. -! - a = 2.0D+00 - - b = 6.0D+00 * beta1 - - c = 3.0D+00 * beta2 + 6.0D+00 * beta1 * beta1 - - d = - 2.0D+00 * ( 1.0D+00 + beta2 + beta1 + beta1 * beta1 ) - - bval = ( a + u * ( b + u * ( c + u * d ) ) ) / delta - - yval = yval + ydata(right) * bval -! -! Beta function associated with node RIGHT+1, (or "phantom node"), -! evaluated in its first interval. -! - bval = 2.0D+00 * u**3 / delta - - if ( right + 1 <= ndata ) then - yval = yval + ydata(right+1) * bval - else - yval = yval + ( 2.0D+00 * ydata(ndata) - ydata(ndata-1) ) * bval - end if - - return -end -subroutine spline_bezier_val ( dim_num, interval_num, data_val, point_num, & - point_t, point_val ) - -!*****************************************************************************80 -! -!! SPLINE_BEZIER_VAL evaluates a cubic Bezier spline. -! -! Discussion: -! -! The cubic Bezier spline of N parts is defined by choosing -! 3*N+1 equally spaced T-abscissa values in the interval [0,N]. -! This defines N subintervals, each of length 1, and each containing -! 4 successives T abscissa values. -! -! At each abscissa value, a DIM_NUM-dimensional Bezier control -! value is assigned. Over each interval, a Bezier cubic function -! is used to define the value of the Bezier spline. To the left of -! the first interval, or to the right of the last interval, -! extrapolation may be used to extend the spline definition to -! the entire real line. -! -! Note that the Bezier spline will pass through the 1st, 4th, -! and in general 3*I+1 control values exactly. The other control -! values are not interpolating points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 June 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) INTERVAL_NUM, the number of intervals. -! -! Input, real ( kind = 8 ) DATA_VAL(DIM_NUM,3*INTERVAL_NUM+1), the control -! values. -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of sample points at -! which the Bezier cubic spline is to be evaluated. -! -! Input, real ( kind = 8 ) POINT_T(POINT_NUM), the "T" values associated -! with the points. A value of T between 0 and 1, for instance, -! is associated with the first interval, and a value of T between -! INTERVAL_NUM-1 and INTERVAL_NUM is in the last interval. -! -! Output, real ( kind = 8 ) POINT_VAL(DIM_NUM,POINT_NUM), the value -! of the Bezier cubic spline at the sample points. -! - implicit none - - integer ( kind = 4 ), parameter :: cubic = 3 - integer ( kind = 4 ) interval_num - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - - real ( kind = 8 ) bernstein_val(0:cubic) - real ( kind = 8 ) data_val(dim_num,cubic*interval_num+1) - integer ( kind = 4 ) dim - integer ( kind = 4 ) interval - integer ( kind = 4 ) offset - integer ( kind = 4 ) point - real ( kind = 8 ) point_t(point_num) - real ( kind = 8 ) point_val(dim_num,point_num) - real ( kind = 8 ) t - real ( kind = 8 ) t_01 - - do point = 1, point_num - - t = point_t(point) - - interval = int ( t + 1 ) - - interval = max ( interval, 1 ) - interval = min ( interval, interval_num ) - - offset = 1 + ( interval - 1 ) * cubic - - t_01 = t - real ( interval - 1, kind = 8 ) - - call bp01 ( cubic, t_01, bernstein_val ) - - do dim = 1, dim_num - point_val(dim,point) = dot_product ( & - data_val(dim,offset:offset+cubic), bernstein_val(0:cubic) ) - end do - - end do - - return -end -subroutine spline_constant_val ( ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_CONSTANT_VAL evaluates a piecewise constant spline at a point. -! -! Discussion: -! -! NDATA-1 points TDATA define NDATA intervals, with the first -! and last being semi-infinite. -! -! The value of the spline anywhere in interval I is YDATA(I). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 November 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points defining -! the spline. NDATA must be at least 1. -! -! Input, real ( kind = 8 ) TDATA(NDATA-1), the breakpoints. The values -! of TDATA should be distinct and increasing. -! -! Input, real ( kind = 8 ) YDATA(NDATA), the values of the spline in -! the intervals defined by the breakpoints. -! -! Input, real ( kind = 8 ) TVAL, the point at which the spline is -! to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the spline at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - integer ( kind = 4 ) i - real ( kind = 8 ) tdata(ndata-1) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval -! -! Check NDATA. -! - if ( ndata < 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CONSTANT_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 1.' - stop 1 - end if - - do i = 1, ndata-1 - if ( tval <= tdata(i) ) then - yval = ydata(i) - return - end if - end do - - yval = ydata(ndata) - - return -end -subroutine spline_cubic_set_full ( n, t, y, ibcbeg, ybcbeg, ibcend, ybcend, ypp ) - -!*****************************************************************************80 -! -!! SPLINE_CUBIC_SET_FULL computes the second derivatives of a piecewise cubic spline. -! -! Discussion: -! -! DELETE THIS FUNCTION WHEN YOU ARE SATISFIED WITH THE CURRENT -! VERSION OF SPLINE_CUBIC_SET. -! -! For data interpolation, the user must call SPLINE_CUBIC_SET to -! determine the second derivative data, passing in the data to be -! interpolated, and the desired boundary conditions. -! -! The data to be interpolated, plus the SPLINE_CUBIC_SET output, -! defines the spline. The user may then call SPLINE_CUBIC_VAL to -! evaluate the spline at any point. -! -! The cubic spline is a piecewise cubic polynomial. The intervals -! are determined by the "knots" or abscissas of the data to be -! interpolated. The cubic spline has continous first and second -! derivatives over the entire interval of interpolation. -! -! For any point T in the interval T(IVAL), T(IVAL+1), the form of -! the spline is -! -! SPL(T) = A(IVAL) -! + B(IVAL) * ( T - T(IVAL) ) -! + C(IVAL) * ( T - T(IVAL) )^2 -! + D(IVAL) * ( T - T(IVAL) )^3 -! -! If we assume that we know the values Y(*) and YPP(*), which represent -! the values and second derivatives of the spline at each knot, then -! the coefficients can be computed as: -! -! A(IVAL) = Y(IVAL) -! B(IVAL) = ( Y(IVAL+1) - Y(IVAL) ) / ( T(IVAL+1) - T(IVAL) ) -! - ( YPP(IVAL+1) + 2 * YPP(IVAL) ) * ( T(IVAL+1) - T(IVAL) ) / 6 -! C(IVAL) = YPP(IVAL) / 2 -! D(IVAL) = ( YPP(IVAL+1) - YPP(IVAL) ) / ( 6 * ( T(IVAL+1) - T(IVAL) ) ) -! -! Since the first derivative of the spline is -! -! SPL'(T) = B(IVAL) -! + 2 * C(IVAL) * ( T - T(IVAL) ) -! + 3 * D(IVAL) * ( T - T(IVAL) )^2, -! -! the requirement that the first derivative be continuous at interior -! knot I results in a total of N-2 equations, of the form: -! -! B(IVAL-1) + 2 C(IVAL-1) * (T(IVAL)-T(IVAL-1)) -! + 3 * D(IVAL-1) * (T(IVAL) - T(IVAL-1))^2 = B(IVAL) -! -! or, setting H(IVAL) = T(IVAL+1) - T(IVAL) -! -! ( Y(IVAL) - Y(IVAL-1) ) / H(IVAL-1) -! - ( YPP(IVAL) + 2 * YPP(IVAL-1) ) * H(IVAL-1) / 6 -! + YPP(IVAL-1) * H(IVAL-1) -! + ( YPP(IVAL) - YPP(IVAL-1) ) * H(IVAL-1) / 2 -! = -! ( Y(IVAL+1) - Y(IVAL) ) / H(IVAL) -! - ( YPP(IVAL+1) + 2 * YPP(IVAL) ) * H(IVAL) / 6 -! -! or -! -! YPP(IVAL-1) * H(IVAL-1) + 2 * YPP(IVAL) * ( H(IVAL-1) + H(IVAL) ) -! + YPP(IVAL) * H(IVAL) -! = -! 6 * ( Y(IVAL+1) - Y(IVAL) ) / H(IVAL) -! - 6 * ( Y(IVAL) - Y(IVAL-1) ) / H(IVAL-1) -! -! Boundary conditions must be applied at the first and last knots. -! The resulting tridiagonal system can be solved for the YPP values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 June 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data points; N must be -! at least 2. -! -! Input, real ( kind = 8 ) T(N), the points where data is specified. -! The values should be distinct, and increasing. -! -! Input, real ( kind = 8 ) Y(N), the data values to be interpolated. -! -! Input, integer ( kind = 4 ) IBCBEG, the left boundary condition flag: -! 0: the spline should be a quadratic over the first interval; -! 1: the first derivative at the left endpoint should be YBCBEG; -! 2: the second derivative at the left endpoint should be YBCBEG; -! 3: Not-a-knot: the third derivative is continuous at T(2). -! -! Input, real ( kind = 8 ) YBCBEG, the left boundary value, if needed. -! -! Input, integer ( kind = 4 ) IBCEND, the right boundary condition flag: -! 0: the spline should be a quadratic over the last interval; -! 1: the first derivative at the right endpoint should be YBCEND; -! 2: the second derivative at the right endpoint should be YBCEND; -! 3: Not-a-knot: the third derivative is continuous at T(N-1). -! -! Input, real ( kind = 8 ) YBCEND, the right boundary value, if needed. -! -! Output, real ( kind = 8 ) YPP(N), the second derivatives of -! the cubic spline. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n,n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) ibcbeg - integer ( kind = 4 ) ibcend - integer ( kind = 4 ) info - real ( kind = 8 ) t(n) - real ( kind = 8 ) y(n) - real ( kind = 8 ) ybcbeg - real ( kind = 8 ) ybcend - real ( kind = 8 ) ypp(n) -! -! Check. -! - if ( n <= 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The number of knots must be at least 2.' - write ( *, '(a,i8)' ) ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - 1 - if ( t(i+1) <= t(i) ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The knots must be strictly increasing, but' - write ( *, '(a,i8,a,g14.6)' ) ' T(', i,') = ', t(i) - write ( *, '(a,i8,a,g14.6)' ) ' T(',i+1,') = ', t(i+1) - stop 1 - end if - end do -! -! Zero out the matrix. -! - a(1:n,1:n) = 0.0D+00 -! -! Set the first equation. -! - if ( ibcbeg == 0 ) then - b(1) = 0.0D+00 - a(1,1) = 1.0D+00 - a(1,2) = -1.0D+00 - else if ( ibcbeg == 1 ) then - b(1) = ( y(2) - y(1) ) / ( t(2) - t(1) ) - ybcbeg - a(1,1) = ( t(2) - t(1) ) / 3.0D+00 - a(1,2) = ( t(2) - t(1) ) / 6.0D+00 - else if ( ibcbeg == 2 ) then - b(1) = ybcbeg - a(1,1) = 1.0D+00 - a(1,2) = 0.0D+00 - else if ( ibcbeg == 3 ) then - b(1) = 0.0D+00 - a(1,1) = - ( t(3) - t(2) ) - a(1,2) = ( t(3) - t(1) ) - a(1,3) = - ( t(2) - t(1) ) - else - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The boundary flag IBCBEG must be 0, 1, 2 or 3.' - write ( *, '(a,i8)' ) ' The input value is IBCBEG = ', ibcbeg - stop 1 - end if -! -! Set the intermediate equations. -! - do i = 2, n - 1 - b(i) = ( y(i+1) - y(i) ) / ( t(i+1) - t(i) ) & - - ( y(i) - y(i-1) ) / ( t(i) - t(i-1) ) - a(i,i-1) = ( t(i) - t(i-1) ) / 6.0D+00 - a(i,i) = ( t(i+1) - t(i-1) ) / 3.0D+00 - a(i,i+1) = ( t(i+1) - t(i) ) / 6.0D+00 - end do -! -! Set the last equation. -! - if ( ibcend == 0 ) then - b(n) = 0.0D+00 - a(n,n-1) = -1.0D+00 - a(n,n) = 1.0D+00 - else if ( ibcend == 1 ) then - b(n) = ybcend - ( y(n) - y(n-1) ) / ( t(n) - t(n-1) ) - a(n,n-1) = ( t(n) - t(n-1) ) / 6.0D+00 - a(n,n) = ( t(n) - t(n-1) ) / 3.0D+00 - else if ( ibcend == 2 ) then - b(n) = ybcend - a(n,n-1) = 0.0D+00 - a(n,n) = 1.0D+00 - else if ( ibcend == 3 ) then - b(n) = 0.0D+00 - a(n,n-2) = - ( t(n) - t(n-1) ) - a(n,n-1) = ( t(n) - t(n-2) ) - a(n,n) = - ( t(n-1) - t(n-2) ) - else - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The boundary flag IBCEND must be 0, 1, 2 or 3.' - write ( *, '(a,i8)' ) ' The input value is IBCEND = ', ibcend - stop 1 - end if -! -! Special case: -! N = 2, IBCBEG = IBCEND = 0. -! - if ( n == 2 .and. ibcbeg == 0 .and. ibcend == 0 ) then - - ypp(1) = 0.0D+00 - ypp(2) = 0.0D+00 -! -! Solve the linear system. -! - else - - call r8ge_fs ( n, a, b, info ) - ypp = b - - end if - - return -end -subroutine spline_cubic_set ( n, t, y, ibcbeg, ybcbeg, ibcend, ybcend, ypp ) - -!*****************************************************************************80 -! -!! SPLINE_CUBIC_SET computes the second derivatives of a piecewise cubic spline. -! -! Discussion: -! -! For data interpolation, the user must call SPLINE_CUBIC_SET to -! determine the second derivative data, passing in the data to be -! interpolated, and the desired boundary conditions. -! -! The data to be interpolated, plus the SPLINE_CUBIC_SET output, -! defines the spline. The user may then call SPLINE_CUBIC_VAL to -! evaluate the spline at any point. -! -! The cubic spline is a piecewise cubic polynomial. The intervals -! are determined by the "knots" or abscissas of the data to be -! interpolated. The cubic spline has continous first and second -! derivatives over the entire interval of interpolation. -! -! For any point T in the interval T(IVAL), T(IVAL+1), the form of -! the spline is -! -! SPL(T) = A(IVAL) -! + B(IVAL) * ( T - T(IVAL) ) -! + C(IVAL) * ( T - T(IVAL) )^2 -! + D(IVAL) * ( T - T(IVAL) )^3 -! -! If we assume that we know the values Y(*) and YPP(*), which represent -! the values and second derivatives of the spline at each knot, then -! the coefficients can be computed as: -! -! A(IVAL) = Y(IVAL) -! B(IVAL) = ( Y(IVAL+1) - Y(IVAL) ) / ( T(IVAL+1) - T(IVAL) ) -! - ( YPP(IVAL+1) + 2 * YPP(IVAL) ) * ( T(IVAL+1) - T(IVAL) ) / 6 -! C(IVAL) = YPP(IVAL) / 2 -! D(IVAL) = ( YPP(IVAL+1) - YPP(IVAL) ) / ( 6 * ( T(IVAL+1) - T(IVAL) ) ) -! -! Since the first derivative of the spline is -! -! SPL'(T) = B(IVAL) -! + 2 * C(IVAL) * ( T - T(IVAL) ) -! + 3 * D(IVAL) * ( T - T(IVAL) )^2, -! -! the requirement that the first derivative be continuous at interior -! knot I results in a total of N-2 equations, of the form: -! -! B(IVAL-1) + 2 C(IVAL-1) * (T(IVAL)-T(IVAL-1)) -! + 3 * D(IVAL-1) * (T(IVAL) - T(IVAL-1))^2 = B(IVAL) -! -! or, setting H(IVAL) = T(IVAL+1) - T(IVAL) -! -! ( Y(IVAL) - Y(IVAL-1) ) / H(IVAL-1) -! - ( YPP(IVAL) + 2 * YPP(IVAL-1) ) * H(IVAL-1) / 6 -! + YPP(IVAL-1) * H(IVAL-1) -! + ( YPP(IVAL) - YPP(IVAL-1) ) * H(IVAL-1) / 2 -! = -! ( Y(IVAL+1) - Y(IVAL) ) / H(IVAL) -! - ( YPP(IVAL+1) + 2 * YPP(IVAL) ) * H(IVAL) / 6 -! -! or -! -! YPP(IVAL-1) * H(IVAL-1) + 2 * YPP(IVAL) * ( H(IVAL-1) + H(IVAL) ) -! + YPP(IVAL) * H(IVAL) -! = -! 6 * ( Y(IVAL+1) - Y(IVAL) ) / H(IVAL) -! - 6 * ( Y(IVAL) - Y(IVAL-1) ) / H(IVAL-1) -! -! Boundary conditions must be applied at the first and last knots. -! The resulting tridiagonal system can be solved for the YPP values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 June 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data points; N must be -! at least 2. -! -! Input, real ( kind = 8 ) T(N), the points where data is specified. -! The values should be distinct, and increasing. -! -! Input, real ( kind = 8 ) Y(N), the data values to be interpolated. -! -! Input, integer ( kind = 4 ) IBCBEG, the left boundary condition flag: -! 0: the spline should be a quadratic over the first interval; -! 1: the first derivative at the left endpoint should be YBCBEG; -! 2: the second derivative at the left endpoint should be YBCBEG; -! 3: Not-a-knot: the third derivative is continuous at T(2). -! -! Input, real ( kind = 8 ) YBCBEG, the left boundary value, if needed. -! -! Input, integer ( kind = 4 ) IBCEND, the right boundary condition flag: -! 0: the spline should be a quadratic over the last interval; -! 1: the first derivative at the right endpoint should be YBCEND; -! 2: the second derivative at the right endpoint should be YBCEND; -! 3: Not-a-knot: the third derivative is continuous at T(N-1). -! -! Input, real ( kind = 8 ) YBCEND, the right boundary value, if needed. -! -! Output, real ( kind = 8 ) YPP(N), the second derivatives of -! the cubic spline. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a1(n) - real ( kind = 8 ) a2(n) - real ( kind = 8 ) a3(n) - real ( kind = 8 ) a4(n) - real ( kind = 8 ) a5(n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - integer ( kind = 4 ) ibcbeg - integer ( kind = 4 ) ibcend - integer ( kind = 4 ) info - real ( kind = 8 ) t(n) - real ( kind = 8 ) y(n) - real ( kind = 8 ) ybcbeg - real ( kind = 8 ) ybcend - real ( kind = 8 ) ypp(n) -! -! Check. -! - if ( n <= 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The number of knots must be at least 2.' - write ( *, '(a,i8)' ) ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - 1 - if ( t(i+1) <= t(i) ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The knots must be strictly increasing, but' - write ( *, '(a,i8,a,g14.6)' ) ' T(', i,') = ', t(i) - write ( *, '(a,i8,a,g14.6)' ) ' T(',i+1,') = ', t(i+1) - stop 1 - end if - end do -! -! Zero out the matrix. -! - a1(1:n) = 0.0D+00 - a2(1:n) = 0.0D+00 - a3(1:n) = 0.0D+00 - a4(1:n) = 0.0D+00 - a5(1:n) = 0.0D+00 -! -! Set the first equation. -! - if ( ibcbeg == 0 ) then - b(1) = 0.0D+00 - a3(1) = 1.0D+00 - a4(1) = -1.0D+00 - else if ( ibcbeg == 1 ) then - b(1) = ( y(2) - y(1) ) / ( t(2) - t(1) ) - ybcbeg - a3(1) = ( t(2) - t(1) ) / 3.0D+00 - a4(1) = ( t(2) - t(1) ) / 6.0D+00 - else if ( ibcbeg == 2 ) then - b(1) = ybcbeg - a3(1) = 1.0D+00 - a4(1) = 0.0D+00 - else if ( ibcbeg == 3 ) then - b(1) = 0.0D+00 - a3(1) = - ( t(3) - t(2) ) - a4(1) = ( t(3) - t(1) ) - a5(1) = - ( t(2) - t(1) ) - else - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The boundary flag IBCBEG must be 0, 1, 2 or 3.' - write ( *, '(a,i8)' ) ' The input value is IBCBEG = ', ibcbeg - stop 1 - end if -! -! Set the intermediate equations. -! - do i = 2, n - 1 - b(i) = ( y(i+1) - y(i) ) / ( t(i+1) - t(i) ) & - - ( y(i) - y(i-1) ) / ( t(i) - t(i-1) ) - a2(i) = ( t(i+1) - t(i) ) / 6.0D+00 - a3(i) = ( t(i+1) - t(i-1) ) / 3.0D+00 - a4(i) = ( t(i) - t(i-1) ) / 6.0D+00 - end do -! -! Set the last equation. -! - if ( ibcend == 0 ) then - b(n) = 0.0D+00 - a2(n) = -1.0D+00 - a3(n) = 1.0D+00 - else if ( ibcend == 1 ) then - b(n) = ybcend - ( y(n) - y(n-1) ) / ( t(n) - t(n-1) ) - a2(n) = ( t(n) - t(n-1) ) / 6.0D+00 - a3(n) = ( t(n) - t(n-1) ) / 3.0D+00 - else if ( ibcend == 2 ) then - b(n) = ybcend - a2(n) = 0.0D+00 - a3(n) = 1.0D+00 - else if ( ibcend == 3 ) then - b(n) = 0.0D+00 - a1(n) = - ( t(n) - t(n-1) ) - a2(n) = ( t(n) - t(n-2) ) - a3(n) = - ( t(n-1) - t(n-2) ) - else - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_CUBIC_SET - Fatal error!' - write ( *, '(a)' ) ' The boundary flag IBCEND must be 0, 1, 2 or 3.' - write ( *, '(a,i8)' ) ' The input value is IBCEND = ', ibcend - stop 1 - end if -! -! Special case: -! N = 2, IBCBEG = IBCEND = 0. -! - if ( n == 2 .and. ibcbeg == 0 .and. ibcend == 0 ) then - - ypp(1) = 0.0D+00 - ypp(2) = 0.0D+00 -! -! Solve the linear system. -! - else - - call penta ( n, a1, a2, a3, a4, a5, b, ypp ) - - end if - - return -end -subroutine penta ( n, a1, a2, a3, a4, a5, b, x ) - -!*****************************************************************************80 -! -!! PENTA solves a pentadiagonal system of linear equations. -! -! Discussion: -! -! The matrix A is pentadiagonal. It is entirely zero, except for -! the main diagaonal, and the two immediate sub- and super-diagonals. -! -! The entries of Row I are stored as: -! -! A(I,I-2) -> A1(I) -! A(I,I-1) -> A2(I) -! A(I,I) -> A3(I) -! A(I,I+1) -> A4(I) -! A(I,I-2) -> A5(I) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 June 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Cheney, Kincaid, -! Numerical Mathematics and Computing, -! 1985, pages 233-236. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! -! Input, real ( kind = 8 ) A1(N), A2(N), A3(N), A4(N), A5(N), the nonzero -! elements of the matrix. Note that the data in A2, A3 and A4 -! is overwritten by this routine during the solution process. -! -! Input, real ( kind = 8 ) B(N), the right hand side of the linear system. -! -! Output, real ( kind = 8 ) X(N), the solution of the linear system. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a1(n) - real ( kind = 8 ) a2(n) - real ( kind = 8 ) a3(n) - real ( kind = 8 ) a4(n) - real ( kind = 8 ) a5(n) - real ( kind = 8 ) b(n) - integer ( kind = 4 ) i - real ( kind = 8 ) x(n) - real ( kind = 8 ) xmult - - do i = 2, n - 1 - xmult = a2(i) / a3(i-1) - a3(i) = a3(i) - xmult * a4(i-1) - a4(i) = a4(i) - xmult * a5(i-1) - b(i) = b(i) - xmult * b(i-1) - xmult = a1(i+1) / a3(i-1) - a2(i+1) = a2(i+1) - xmult * a4(i-1) - a3(i+1) = a3(i+1) - xmult * a5(i-1) - b(i+1) = b(i+1) - xmult * b(i-1) - end do - - xmult = a2(n) / a3(n-1) - a3(n) = a3(n) - xmult * a4(n-1) - x(n) = ( b(n) - xmult * b(n-1) ) / a3(n) - x(n-1) = ( b(n-1) - a4(n-1) * x(n) ) / a3(n-1) - do i = n - 2, 1, -1 - x(i) = ( b(i) - a4(i) * x(i+1) - a5(i) * x(i+2) ) / a3(i) - end do - - return -end -subroutine spline_cubic_val ( n, t, y, ypp, tval, yval, ypval, yppval ) - -!*****************************************************************************80 -! -!! SPLINE_CUBIC_VAL evaluates a piecewise cubic spline at a point. -! -! Discussion: -! -! SPLINE_CUBIC_SET must have already been called to define the -! values of YPP. -! -! For any point T in the interval T(IVAL), T(IVAL+1), the form of -! the spline is -! -! SPL(T) = A -! + B * ( T - T(IVAL) ) -! + C * ( T - T(IVAL) )^2 -! + D * ( T - T(IVAL) )^3 -! -! Here: -! A = Y(IVAL) -! B = ( Y(IVAL+1) - Y(IVAL) ) / ( T(IVAL+1) - T(IVAL) ) -! - ( YPP(IVAL+1) + 2 * YPP(IVAL) ) * ( T(IVAL+1) - T(IVAL) ) / 6 -! C = YPP(IVAL) / 2 -! D = ( YPP(IVAL+1) - YPP(IVAL) ) / ( 6 * ( T(IVAL+1) - T(IVAL) ) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 November 2000 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data values. -! -! Input, real ( kind = 8 ) T(N), the knot values. -! -! Input, real ( kind = 8 ) Y(N), the data values at the knots. -! -! Input, real ( kind = 8 ) YPP(N), the second derivatives of the -! spline at the knots. -! -! Input, real ( kind = 8 ) TVAL, a point, typically between T(1) and -! T(N), at which the spline is to be evalulated. If TVAL lies outside -! this range, extrapolation is used. -! -! Output, real ( kind = 8 ) YVAL, YPVAL, YPPVAL, the value of the spline, and -! its first two derivatives at TVAL. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) dt - real ( kind = 8 ) h - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) t(n) - real ( kind = 8 ) tval - real ( kind = 8 ) y(n) - real ( kind = 8 ) ypp(n) - real ( kind = 8 ) yppval - real ( kind = 8 ) ypval - real ( kind = 8 ) yval -! -! Determine the interval [T(LEFT), T(RIGHT)] that contains TVAL. -! Values below T(1) or above T(N) use extrapolation. -! - call r8vec_bracket ( n, t, tval, left, right ) -! -! Evaluate the polynomial. -! - dt = tval - t(left) - h = t(right) - t(left) - - yval = y(left) & - + dt * ( ( y(right) - y(left) ) / h & - - ( ypp(right) / 6.0D+00 + ypp(left) / 3.0D+00 ) * h & - + dt * ( 0.5D+00 * ypp(left) & - + dt * ( ( ypp(right) - ypp(left) ) / ( 6.0D+00 * h ) ) ) ) - - ypval = ( y(right) - y(left) ) / h & - - ( ypp(right) / 6.0D+00 + ypp(left) / 3.0D+00 ) * h & - + dt * ( ypp(left) & - + dt * ( 0.5D+00 * ( ypp(right) - ypp(left) ) / h ) ) - - yppval = ypp(left) + dt * ( ypp(right) - ypp(left) ) / h - - return -end -subroutine spline_cubic_val2 ( n, t, y, ypp, left, tval, yval, ypval, yppval ) - -!*****************************************************************************80 -! -!! SPLINE_CUBIC_VAL2 evaluates a piecewise cubic spline at a point. -! -! Discussion: -! -! This routine is a modification of SPLINE_CUBIC_VAL; it allows the -! user to speed up the code by suggesting the appropriate T interval -! to search first. -! -! SPLINE_CUBIC_SET must have already been called to define the -! values of YPP. -! -! In the LEFT interval, let RIGHT = LEFT+1. The form of the spline is -! -! SPL(T) = -! A -! + B * ( T - T(LEFT) ) -! + C * ( T - T(LEFT) )^2 -! + D * ( T - T(LEFT) )^3 -! -! Here: -! A = Y(LEFT) -! B = ( Y(RIGHT) - Y(LEFT) ) / ( T(RIGHT) - T(LEFT) ) -! - ( YPP(RIGHT) + 2 * YPP(LEFT) ) * ( T(RIGHT) - T(LEFT) ) / 6 -! C = YPP(LEFT) / 2 -! D = ( YPP(RIGHT) - YPP(LEFT) ) / ( 6 * ( T(RIGHT) - T(LEFT) ) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Carl deBoor, -! A Practical Guide to Splines, -! Springer, 2001, -! ISBN: 0387953663. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of knots. -! -! Input, real ( kind = 8 ) T(N), the knot values. -! -! Input, real ( kind = 8 ) Y(N), the data values at the knots. -! -! Input, real ( kind = 8 ) YPP(N), the second derivatives of the spline at -! the knots. -! -! Input/output, integer ( kind = 4 ) LEFT, the suggested T interval to -! search. LEFT should be between 1 and N-1. If LEFT is not in this range, -! then its value will be ignored. On output, LEFT is set to the -! actual interval in which TVAL lies. -! -! Input, real ( kind = 8 ) TVAL, a point, typically between T(1) and T(N), at -! which the spline is to be evalulated. If TVAL lies outside -! this range, extrapolation is used. -! -! Output, real ( kind = 8 ) YVAL, YPVAL, YPPVAL, the value of the spline, and -! its first two derivatives at TVAL. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) dt - real ( kind = 8 ) h - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) t(n) - real ( kind = 8 ) tval - real ( kind = 8 ) y(n) - real ( kind = 8 ) ypp(n) - real ( kind = 8 ) yppval - real ( kind = 8 ) ypval - real ( kind = 8 ) yval -! -! Determine the interval [T(LEFT), T(RIGHT)] that contains TVAL. -! -! What you want from R8VEC_BRACKET3 is that TVAL is to be computed -! by the data in interval [T(LEFT), T(RIGHT)]. -! - call r8vec_bracket3 ( n, t, tval, left ) - right = left + 1 -! -! In the interval LEFT, the polynomial is in terms of a normalized -! coordinate ( DT / H ) between 0 and 1. -! - dt = tval - t(left) - h = t(right) - t(left) - - yval = y(left) + dt * ( ( y(right) - y(left) ) / h & - - ( ypp(right) / 6.0D+00 + ypp(left) / 3.0D+00 ) * h & - + dt * ( 0.5D+00 * ypp(left) & - + dt * ( ( ypp(right) - ypp(left) ) / ( 6.0D+00 * h ) ) ) ) - - ypval = ( y(right) - y(left) ) / h & - - ( ypp(right) / 6.0D+00 + ypp(left) / 3.0D+00 ) * h & - + dt * ( ypp(left) & - + dt * ( 0.5D+00 * ( ypp(right) - ypp(left) ) / h ) ) - - yppval = ypp(left) + dt * ( ypp(right) - ypp(left) ) / h - - return -end -subroutine spline_hermite_set ( ndata, tdata, ydata, ypdata, c ) - -!*****************************************************************************80 -! -!! SPLINE_HERMITE_SET sets up a piecewise cubic Hermite interpolant. -! -! Discussion: -! -! Once the array C is computed, then in the interval -! (TDATA(I), TDATA(I+1)), the interpolating Hermite polynomial -! is given by -! -! SVAL(TVAL) = C(1,I) -! + ( TVAL - TDATA(I) ) * ( C(2,I) -! + ( TVAL - TDATA(I) ) * ( C(3,I) -! + ( TVAL - TDATA(I) ) * C(4,I) ) ) -! -! This is algorithm CALCCF of Conte and deBoor. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Samuel Conte, Carl deBoor, -! Elementary Numerical Analysis, -! Second Edition, -! McGraw Hill, 1972, -! ISBN: 07-012446-4, -! LC: QA297.C65. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! NDATA must be at least 2. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data points. -! The entries of TDATA are assumed to be strictly increasing. -! -! Input, real ( kind = 8 ) Y(NDATA), YP(NDATA), the value of the -! function and its derivative at TDATA(1:NDATA). -! -! Output, real ( kind = 8 ) C(4,NDATA), the coefficients of the -! Hermite polynomial. -! C(1,1:NDATA) = Y(1:NDATA) and C(2,1:NDATA) = YP(1:NDATA). -! C(3,1:NDATA-1) and C(4,1:NDATA-1) are the quadratic and cubic -! coefficients. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) c(4,ndata) - real ( kind = 8 ) divdif1 - real ( kind = 8 ) divdif3 - real ( kind = 8 ) dt - integer ( kind = 4 ) i - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) ypdata(ndata) -! -! Check NDATA. -! - if ( ndata < 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_HERMITE_SET - Fatal error!' - write ( *, '(a)' ) ' NDATA < 2.' - stop 1 - end if - - c(1,1:ndata) = ydata(1:ndata) - c(2,1:ndata) = ypdata(1:ndata) - - do i = 1, ndata - 1 - dt = tdata(i+1) - tdata(i) - divdif1 = ( c(1,i+1) - c(1,i) ) / dt - divdif3 = c(2,i) + c(2,i+1) - 2.0D+00 * divdif1 - c(3,i) = ( divdif1 - c(2,i) - divdif3 ) / dt - c(4,i) = divdif3 / ( dt * dt ) - end do - - c(3,ndata) = 0.0D+00 - c(4,ndata) = 0.0D+00 - - return -end -subroutine spline_hermite_val ( ndata, tdata, c, tval, sval, spval ) - -!*****************************************************************************80 -! -!! SPLINE_HERMITE_VAL evaluates a piecewise cubic Hermite interpolant. -! -! Discussion: -! -! SPLINE_HERMITE_SET must be called first, to set up the -! spline data from the raw function and derivative data. -! -! In the interval (TDATA(I), TDATA(I+1)), the interpolating -! Hermite polynomial is given by -! -! SVAL(TVAL) = C(1,I) -! + ( TVAL - TDATA(I) ) * ( C(2,I) -! + ( TVAL - TDATA(I) ) * ( C(3,I) -! + ( TVAL - TDATA(I) ) * C(4,I) ) ) -! -! and -! -! SVAL'(TVAL) = C(2,I) -! + ( TVAL - TDATA(I) ) * ( 2 * C(3,I) -! + ( TVAL - TDATA(I) ) * 3 * C(4,I) ) -! -! This is algorithm PCUBIC of Conte and deBoor. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Samuel Conte, Carl deBoor, -! Elementary Numerical Analysis, -! Second Edition, -! McGraw Hill, 1972, -! ISBN: 07-012446-4, -! LC: QA297.C65. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! NDATA must be at least 2. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data points. -! The entries of TDATA are assumed to be strictly increasing. -! -! Input, real ( kind = 8 ) C(4,NDATA), the coefficient data computed by -! SPLINE_HERMITE_SET. -! -! Input, real ( kind = 8 ) TVAL, the point where the interpolant is to -! be evaluated. -! -! Output, real ( kind = 8 ) SVAL, SPVAL, the value of the interpolant -! and its derivative at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) c(4,ndata) - real ( kind = 8 ) dt - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) spval - real ( kind = 8 ) sval - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval -! -! Check NDATA. -! - if ( ndata < 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_HERMITE_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 2.' - stop 1 - end if -! -! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] that contains -! or is nearest to TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the cubic polynomial. -! - dt = tval - tdata(left) - - sval = c(1,left) + dt * ( c(2,left) + dt * ( c(3,left) + dt * c(4,left) ) ) - - spval = c(2,left) + dt * ( 2.0D+00 * c(3,left) + dt * 3.0D+00 * c(4,left) ) - - return -end -subroutine spline_linear_int ( ndata, tdata, ydata, a, b, int_val ) - -!*****************************************************************************80 -! -!! SPLINE_LINEAR_INT evaluates the integral of a piecewise linear spline. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 November 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points defining -! the spline. NDATA must be at least 2. -! -! Input, real ( kind = 8 ) TDATA(NDATA), YDATA(NDATA), the values of -! the independent and dependent variables at the data points. The -! values of TDATA should be distinct and increasing. -! -! Input, real ( kind = 8 ) A, B, the interval over which the -! integral is desired. -! -! Output, real ( kind = 8 ) INT_VAL, the value of the integral. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) a - real ( kind = 8 ) a_copy - integer ( kind = 4 ) a_left - integer ( kind = 4 ) a_right - real ( kind = 8 ) b - real ( kind = 8 ) b_copy - integer ( kind = 4 ) b_left - integer ( kind = 4 ) b_right - integer ( kind = 4 ) i_left - real ( kind = 8 ) int_val - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yp - real ( kind = 8 ) yval -! -! Check NDATA. -! - if ( ndata < 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_LINEAR_INT - Fatal error!' - write ( *, '(a)' ) ' NDATA < 2.' - stop 1 - end if - - int_val = 0.0D+00 - - if ( a == b ) then - return - end if - - a_copy = min ( a, b ) - b_copy = max ( a, b ) -! -! Find the interval [ TDATA(A_LEFT), TDATA(A_RIGHT) ] that contains, or is -! nearest to, A. -! - call r8vec_bracket ( ndata, tdata, a_copy, a_left, a_right ) -! -! Find the interval [ TDATA(B_LEFT), TDATA(B_RIGHT) ] that contains, or is -! nearest to, B. -! - call r8vec_bracket ( ndata, tdata, b_copy, b_left, b_right ) -! -! If A and B are in the same interval... -! - if ( a_left == b_left ) then - - tval = ( a_copy + b_copy ) / 2.0D+00 - - yp = ( ydata(a_right) - ydata(a_left) ) / & - ( tdata(a_right) - tdata(a_left) ) - - yval = ydata(a_left) + ( tval - tdata(a_left) ) * yp - - int_val = yval * ( b_copy - a_copy ) - - return - end if -! -! Otherwise, integrate from: -! -! A to TDATA(A_RIGHT), -! TDATA(A_RIGHT) to TDATA(A_RIGHT+1),... -! TDATA(B_LEFT-1) to TDATA(B_LEFT), -! TDATA(B_LEFT) to B. -! -! Use the fact that the integral of a linear function is the -! value of the function at the midpoint times the width of the interval. -! - tval = ( a_copy + tdata(a_right) ) / 2.0D+00 - - yp = ( ydata(a_right) - ydata(a_left) ) / & - ( tdata(a_right) - tdata(a_left) ) - - yval = ydata(a_left) + ( tval - tdata(a_left) ) * yp - - int_val = int_val + yval * ( tdata(a_right) - a_copy ) - - do i_left = a_right, b_left - 1 - - tval = ( tdata(i_left+1) + tdata(i_left) ) / 2.0D+00 - - yp = ( ydata(i_left+1) - ydata(i_left) ) / & - ( tdata(i_left+1) - tdata(i_left) ) - - yval = ydata(i_left) + ( tval - tdata(i_left) ) * yp - - int_val = int_val + yval * ( tdata(i_left + 1) - tdata(i_left) ) - - end do - - tval = ( tdata(b_left) + b_copy ) / 2.0D+00 - - yp = ( ydata(b_right) - ydata(b_left) ) / & - ( tdata(b_right) - tdata(b_left) ) - - yval = ydata(b_left) + ( tval - tdata(b_left) ) * yp - - int_val = int_val + yval * ( b_copy - tdata(b_left) ) - - if ( b < a ) then - int_val = - int_val - end if - - return -end -subroutine spline_linear_intset ( n, int_x, int_v, data_x, data_y ) - -!*****************************************************************************80 -! -!! SPLINE_LINEAR_INTSET: piecewise linear spline with given integral properties. -! -! Discussion: -! -! The user has in mind an interval, divided by INT_N+1 points into -! INT_N intervals. A linear spline is to be constructed, -! with breakpoints at the centers of each interval, and extending -! continuously to the left of the first and right of the last -! breakpoints. The constraint on the linear spline is that it is -! required that it have a given integral value over each interval. -! -! A tridiagonal linear system of equations is solved for the -! values of the spline at the breakpoints. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 January 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of intervals. -! -! Input, real ( kind = 8 ) INT_X(N+1), the points that define the intervals. -! Interval I lies between INT_X(I) and INT_X(I+1). -! -! Input, real ( kind = 8 ) INT_V(N), the desired value of the integral of the -! linear spline over each interval. -! -! Output, real ( kind = 8 ) DATA_X(N), DATA_Y(N), the values of the -! independent and dependent variables at the data points. The values -! of DATA_X are the interval midpoints. The values of DATA_Y are -! determined in such a way that the exact integral of the linear -! spline over interval I is equal to INT_V(I). -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(3,n) - real ( kind = 8 ) data_x(n) - real ( kind = 8 ) data_y(n) - real ( kind = 8 ) int_v(n) - real ( kind = 8 ) int_x(n+1) -! -! Set up the easy stuff. -! - data_x(1:n) = 0.5D+00 * ( int_x(1:n) + int_x(2:n+1) ) -! -! Set up C, D, E, the coefficients of the linear system. -! - a(3,1:n-2) = 1.0D+00 & - - ( 0.5D+00 * ( data_x(2:n-1) + int_x(2:n-1) ) - data_x(1:n-2) ) & - / ( data_x(2:n-1) - data_x(1:n-2) ) - a(3,n-1) = 0.0D+00 - a(3,n) = 0.0D+00 - - a(2,1) = int_x(2) - int_x(1) - - a(2,2:n-1) = 1.0D+00 & - + ( 0.5D+00 * ( data_x(2:n-1) + int_x(2:n-1) ) & - - data_x(1:n-2) ) & - / ( data_x(2:n-1) - data_x(1:n-2) ) & - - ( 0.5D+00 * ( data_x(2:n-1) + int_x(3:n) ) - data_x(2:n-1) ) & - / ( data_x(3:n) - data_x(2:n-1) ) - - a(2,n) = int_x(n+1) - int_x(n) - - a(1,1) = 0.0D+00 - a(1,2) = 0.0D+00 - - a(1,3:n) = ( 0.5D+00 * ( data_x(2:n-1) + int_x(3:n) ) & - - data_x(2:n-1) ) / ( data_x(3:n) - data_x(2:n-1) ) -! -! Set up DATA_Y, which begins as the right hand side of the linear system. -! - data_y(1) = int_v(1) - data_y(2:n-1) = 2.0D+00 * int_v(2:n-1) / ( int_x(3:n) - int_x(2:n-1) ) - data_y(n) = int_v(n) -! -! Solve the linear system. -! - call r83_np_fs ( n, a, data_y, data_y ) - - return -end -subroutine spline_linear_val ( ndata, tdata, ydata, tval, yval, ypval ) - -!*****************************************************************************80 -! -!! SPLINE_LINEAR_VAL evaluates a piecewise linear spline at a point. -! -! Discussion: -! -! Because of the extremely simple form of the linear spline, -! the raw data points ( TDATA(I), YDATA(I)) can be used directly to -! evaluate the spline at any point. No processing of the data -! is required. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points defining -! the spline. NDATA must be at least 2. -! -! Input, real ( kind = 8 ) TDATA(NDATA), YDATA(NDATA), the values of -! the independent and dependent variables at the data points. The -! values of TDATA should be distinct and increasing. -! -! Input, real ( kind = 8 ) TVAL, the point at which the spline is -! to be evaluated. -! -! Output, real ( kind = 8 ) YVAL, YPVAL, the value of the spline and -! its first derivative dYdT at TVAL. YPVAL is not reliable if TVAL -! is exactly equal to TDATA(I) for some I. -! - implicit none - - integer ( kind = 4 ) ndata - - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) ypval - real ( kind = 8 ) yval -! -! Check NDATA. -! - if ( ndata < 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_LINEAR_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 2.' - stop 1 - end if -! -! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] that contains, or is -! nearest to, TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Now evaluate the piecewise linear function. -! - ypval = ( ydata(right) - ydata(left) ) / ( tdata(right) - tdata(left) ) - - yval = ydata(left) + ( tval - tdata(left) ) * ypval - - return -end -subroutine spline_overhauser_nonuni_val ( ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_OVERHAUSER_NONUNI_VAL evaluates the nonuniform Overhauser spline. -! -! Discussion: -! -! The nonuniformity refers to the fact that the abscissa values -! need not be uniformly spaced. -! -! Thanks to Doug Fortune for pointing out that the point distances -! used to define ALPHA and BETA should be the Euclidean distances -! between the points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 May 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! 3 <= NDATA is required. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data points. -! The values of TDATA are assumed to be distinct and increasing. -! -! Input, real ( kind = 8 ) YDATA(NDATA), the data values. -! -! Input, real ( kind = 8 ) TVAL, the value where the spline is to -! be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the spline at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) alpha - real ( kind = 8 ) beta - real ( kind = 8 ) d21 - real ( kind = 8 ) d32 - real ( kind = 8 ) d43 - integer ( kind = 4 ) left - real ( kind = 8 ) mbasis(4,4) - real ( kind = 8 ) mbasis_l(3,3) - real ( kind = 8 ) mbasis_r(3,3) - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval -! -! Check NDATA. -! - if ( ndata < 3 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_NONUNI_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 3.' - stop 1 - end if -! -! Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the spline in the given interval. -! - if ( left == 1 ) then - - d21 = sqrt ( ( tdata(2) - tdata(1) )**2 & - + ( ydata(2) - ydata(1) )**2 ) - - d32 = sqrt ( ( tdata(3) - tdata(2) )**2 & - + ( ydata(3) - ydata(2) )**2 ) - - alpha = d21 / ( d32 + d21 ) - - call basis_matrix_overhauser_nul ( alpha, mbasis_l ) - - call basis_matrix_tmp ( left, 3, mbasis_l, ndata, tdata, ydata, tval, yval ) - - else if ( left < ndata - 1 ) then - - d21 = sqrt ( ( tdata(left) - tdata(left-1) )**2 & - + ( ydata(left) - ydata(left-1) )**2 ) - - d32 = sqrt ( ( tdata(left+1) - tdata(left) )**2 & - + ( ydata(left+1) - ydata(left) )**2 ) - - d43 = sqrt ( ( tdata(left+2) - tdata(left+1) )**2 & - + ( ydata(left+2) - ydata(left+1) )**2 ) - - alpha = d21 / ( d32 + d21 ) - beta = d32 / ( d43 + d32 ) - - call basis_matrix_overhauser_nonuni ( alpha, beta, mbasis ) - - call basis_matrix_tmp ( left, 4, mbasis, ndata, tdata, ydata, tval, yval ) - - else if ( left == ndata - 1 ) then - - d32 = sqrt ( ( tdata(ndata-1) - tdata(ndata-2) )**2 & - + ( ydata(ndata-1) - ydata(ndata-2) )**2 ) - - d43 = sqrt ( ( tdata(ndata) - tdata(ndata-1) )**2 & - + ( ydata(ndata) - ydata(ndata-1) )**2 ) - - beta = d32 / ( d43 + d32 ) - - call basis_matrix_overhauser_nur ( beta, mbasis_r ) - - call basis_matrix_tmp ( left, 3, mbasis_r, ndata, tdata, ydata, tval, yval ) - - else - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_NONUNI_VAL - Fatal error!' - write ( *, '(a,i8)' ) ' Nonsensical value of LEFT = ', left - write ( *, '(a,i8)' ) ' but 0 < LEFT < NDATA = ', ndata - write ( *, '(a)' ) ' is required.' - stop 1 - - end if - - return -end -subroutine spline_overhauser_uni_val ( ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_OVERHAUSER_UNI_VAL evaluates the uniform Overhauser spline. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! NDATA must be at least 3. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data points. -! The values of TDATA are assumed to be distinct and increasing. -! This routine also assumes that the values of TDATA are uniformly -! spaced; for instance, TDATA(1) = 10, TDATA(2) = 11, TDATA(3) = 12... -! -! Input, real ( kind = 8 ) YDATA(NDATA), the data values. -! -! Input, real ( kind = 8 ) TVAL, the value where the spline is to -! be evaluated. -! -! Output, real ( kind = 8 ) YVAL, the value of the spline at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - - integer ( kind = 4 ) left - real ( kind = 8 ) mbasis(4,4) - real ( kind = 8 ) mbasis_l(3,3) - real ( kind = 8 ) mbasis_r(3,3) - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) yval -! -! Check NDATA. -! - if ( ndata < 3 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_UNI_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 3.' - stop 1 - end if -! -! Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the spline in the given interval. -! - if ( left == 1 ) then - - call basis_matrix_overhauser_uni_l ( mbasis_l ) - - call basis_matrix_tmp ( left, 3, mbasis_l, ndata, tdata, ydata, tval, yval ) - - else if ( left < ndata - 1 ) then - - call basis_matrix_overhauser_uni ( mbasis ) - - call basis_matrix_tmp ( left, 4, mbasis, ndata, tdata, ydata, tval, yval ) - - else if ( left == ndata - 1 ) then - - call basis_matrix_overhauser_uni_r ( mbasis_r ) - - call basis_matrix_tmp ( left, 3, mbasis_r, ndata, tdata, ydata, tval, yval ) - - end if - - return -end -subroutine spline_overhauser_val ( dim_num, ndata, tdata, ydata, tval, yval ) - -!*****************************************************************************80 -! -!! SPLINE_OVERHAUSER_VAL evaluates an Overhauser spline. -! -! Discussion: -! -! Over the first and last intervals, the Overhauser spline is a -! quadratic. In the intermediate intervals, it is a piecewise cubic. -! The Overhauser spline is also known as the Catmull-Rom spline. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! JA Brewer, DC Anderson, -! Visual Interaction with Overhauser Curves and Surfaces, -! SIGGRAPH 77, -! in Proceedings of the 4th Annual Conference on Computer Graphics -! and Interactive Techniques, -! ASME, July 1977, pages 132-137. -! -! Edwin Catmull, Raphael Rom, -! A Class of Local Interpolating Splines, -! in Computer Aided Geometric Design, -! edited by Robert Barnhill, Richard Reisenfeld, -! Academic Press, 1974, pages 317-326, -! ISBN: 0120790505. -! -! David Rogers, Alan Adams, -! Mathematical Elements of Computer Graphics, -! Second Edition, -! McGraw Hill, 1989, -! ISBN: 0070535299. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of a single data point. -! DIM_NUM must be at least 1. -! -! Input, integer ( kind = 4 ) NDATA, the number of data points. -! NDATA must be at least 3. -! -! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data -! points. The values in TDATA must be in strictly ascending order. -! -! Input, real ( kind = 8 ) YDATA(DIM_NUM,NDATA), the data points -! corresponding to the abscissas. -! -! Input, real ( kind = 8 ) TVAL, the abscissa value at which the spline -! is to be evaluated. Normally, TDATA(1) <= TVAL <= T(NDATA), and -! the data will be interpolated. For TVAL outside this range, -! extrapolation will be used. -! -! Output, real ( kind = 8 ) YVAL(DIM_NUM), the value of the spline at TVAL. -! - implicit none - - integer ( kind = 4 ) ndata - integer ( kind = 4 ) dim_num - - integer ( kind = 4 ) left - integer ( kind = 4 ) order - integer ( kind = 4 ) right - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) ydata(dim_num,ndata) - real ( kind = 8 ) yl(dim_num) - real ( kind = 8 ) yr(dim_num) - real ( kind = 8 ) yval(dim_num) -! -! Check. -! - call r8vec_order_type ( ndata, tdata, order ) - - if ( order /= 2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_VAL - Fatal error!' - write ( *, '(a)' ) ' The data abscissas are not strictly ascending.' - stop 1 - end if - - if ( ndata < 3 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 3.' - stop 1 - end if - - if ( dim_num < 1 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_OVERHAUSER_VAL - Fatal error!' - write ( *, '(a)' ) ' DIM_NUM < 1.' - stop 1 - end if -! -! Locate the abscissa interval T(LEFT), T(LEFT+1) nearest to or -! containing TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Evaluate the "left hand" quadratic defined at T(LEFT-1), T(LEFT), T(RIGHT). -! - if ( 0 < left-1 ) then - call parabola_val2 ( dim_num, ndata, tdata, ydata, left-1, tval, yl ) - end if -! -! Evaluate the "right hand" quadratic defined at T(LEFT), T(RIGHT), T(RIGHT+1). -! - if ( right+1 <= ndata ) then - call parabola_val2 ( dim_num, ndata, tdata, ydata, left, tval, yr ) - end if -! -! Average the quadratics. -! - if ( left == 1 ) then - - yval(1:dim_num) = yr(1:dim_num) - - else if ( right < ndata ) then - - yval(1:dim_num) = & - ( ( tdata(right) - tval ) * yl(1:dim_num) & - + ( tval - tdata(left) ) * yr(1:dim_num) ) & - / ( tdata(right) - tdata(left) ) - - else - - yval(1:dim_num) = yl(1:dim_num) - - end if - - return -end -subroutine spline_pchip_set ( n, x, f, d ) - -!*****************************************************************************80 -! -!! SPLINE_PCHIP_SET sets derivatives for a piecewise cubic Hermite interpolant. -! -! Discussion: -! -! This routine computes what would normally be called a Hermite -! interpolant. However, the user is only required to supply function -! values, not derivative values as well. This routine computes -! "suitable" derivative values, so that the resulting Hermite interpolant -! has desirable shape and monotonicity properties. -! -! The interpolant will have an extremum at each point where -! monotonicity switches direction. -! -! The resulting piecewise cubic Hermite function may be evaluated -! by SPLINE_PCHIP_VAL. -! -! This routine was originally named "PCHIM". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 December 2008 -! -! Author: -! -! Original FORTRAN77 version by Fred Fritsch. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Fred Fritsch, Ralph Carlson, -! Monotone Piecewise Cubic Interpolation, -! SIAM Journal on Numerical Analysis, -! Volume 17, Number 2, April 1980, pages 238-246. -! -! Fred Fritsch, Judy Butland, -! A Method for Constructing Local Monotone Piecewise Cubic Interpolants, -! SIAM Journal on Scientific and Statistical Computing, -! Volume 5, Number 2, 1984, pages 300-304. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data points. N must be -! at least 2. -! -! Input, real ( kind = 8 ) X(N), the strictly increasing independent -! variable values. -! -! Input, real ( kind = 8 ) F(N), dependent variable values to be -! interpolated. F(I) is the value corresponding to X(I). -! This routine is designed for monotonic data, but it will work for any -! F array. It will force extrema at points where monotonicity switches -! direction. -! -! Output, real ( kind = 8 ) D(N), the derivative values at the -! data points. If the data are monotonic, these values will determine -! a monotone cubic Hermite function. -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) d(n) - real ( kind = 8 ) del1 - real ( kind = 8 ) del2 - real ( kind = 8 ) dmax - real ( kind = 8 ) dmin - real ( kind = 8 ) drat1 - real ( kind = 8 ) drat2 - real ( kind = 8 ) dsave - real ( kind = 8 ) f(n) - real ( kind = 8 ) h1 - real ( kind = 8 ) h2 - real ( kind = 8 ) hsum - real ( kind = 8 ) hsumt3 - integer ( kind = 4 ) i - integer ( kind = 4 ) ierr - integer ( kind = 4 ) nless1 - real ( kind = 8 ) pchst - real ( kind = 8 ) temp - real ( kind = 8 ) w1 - real ( kind = 8 ) w2 - real ( kind = 8 ) x(n) -! -! Check the arguments. -! - if ( n < 2 ) then - ierr = -1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_SET - Fatal error!' - write ( *, '(a)' ) ' Number of data points less than 2.' - stop 1 - end if - - do i = 2, n - if ( x(i) <= x(i-1) ) then - ierr = -3 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_SET - Fatal error!' - write ( *, '(a)' ) ' X array not strictly increasing.' - stop 1 - end if - end do - - ierr = 0 - nless1 = n - 1 - h1 = x(2) - x(1) - del1 = ( f(2) - f(1) ) / h1 - dsave = del1 -! -! Special case N=2, use linear interpolation. -! - if ( n == 2 ) then - d(1) = del1 - d(n) = del1 - return - end if -! -! Normal case, 3 <= N. -! - h2 = x(3) - x(2) - del2 = ( f(3) - f(2) ) / h2 -! -! Set D(1) via non-centered three point formula, adjusted to be -! shape preserving. -! - hsum = h1 + h2 - w1 = ( h1 + hsum ) / hsum - w2 = -h1 / hsum - d(1) = w1 * del1 + w2 * del2 - - if ( pchst ( d(1), del1 ) <= 0.0D+00 ) then - - d(1) = 0.0D+00 -! -! Need do this check only if monotonicity switches. -! - else if ( pchst ( del1, del2 ) < 0.0D+00 ) then - - dmax = 3.0D+00 * del1 - - if ( abs ( dmax ) < abs ( d(1) ) ) then - d(1) = dmax - end if - - end if -! -! Loop through interior points. -! - do i = 2, nless1 - - if ( 2 < i ) then - h1 = h2 - h2 = x(i+1) - x(i) - hsum = h1 + h2 - del1 = del2 - del2 = ( f(i+1) - f(i) ) / h2 - end if -! -! Set D(I)=0 unless data are strictly monotonic. -! - d(i) = 0.0D+00 - - temp = pchst ( del1, del2 ) - - if ( temp < 0.0D+00 ) then - - ierr = ierr + 1 - dsave = del2 -! -! Count number of changes in direction of monotonicity. -! - else if ( temp == 0.0D+00 ) then - - if ( del2 /= 0.0D+00 ) then - if ( pchst ( dsave, del2 ) < 0.0D+00 ) then - ierr = ierr + 1 - end if - dsave = del2 - end if -! -! Use Brodlie modification of Butland formula. -! - else - - hsumt3 = 3.0D+00 * hsum - w1 = ( hsum + h1 ) / hsumt3 - w2 = ( hsum + h2 ) / hsumt3 - dmax = max ( abs ( del1 ), abs ( del2 ) ) - dmin = min ( abs ( del1 ), abs ( del2 ) ) - drat1 = del1 / dmax - drat2 = del2 / dmax - d(i) = dmin / ( w1 * drat1 + w2 * drat2 ) - - end if - - end do -! -! Set D(N) via non-centered three point formula, adjusted to be -! shape preserving. -! - w1 = -h2 / hsum - w2 = ( h2 + hsum ) / hsum - d(n) = w1 * del1 + w2 * del2 - - if ( pchst ( d(n), del2 ) <= 0.0D+00 ) then - d(n) = 0.0D+00 - else if ( pchst ( del1, del2 ) < 0.0D+00 ) then -! -! Need do this check only if monotonicity switches. -! - dmax = 3.0D+00 * del2 - - if ( abs ( dmax ) < abs ( d(n) ) ) then - d(n) = dmax - end if - - end if - - return -end -subroutine spline_pchip_val ( n, x, f, d, ne, xe, fe ) - -!*****************************************************************************80 -! -!! SPLINE_PCHIP_VAL evaluates a piecewise cubic Hermite function. -! -! Description: -! -! This routine may be used by itself for Hermite interpolation, or as an -! evaluator for SPLINE_PCHIP_SET. -! -! This routine evaluates the cubic Hermite function at the points XE. -! -! Most of the coding between the call to CHFEV and the end of -! the IR loop could be eliminated if it were permissible to -! assume that XE is ordered relative to X. -! -! CHFEV does not assume that X1 is less than X2. Thus, it would -! be possible to write a version of SPLINE_PCHIP_VAL that assumes a strictly -! decreasing X array by simply running the IR loop backwards -! and reversing the order of appropriate tests. -! -! The present code has a minor bug, which I have decided is not -! worth the effort that would be required to fix it. -! If XE contains points in [X(N-1),X(N)], followed by points less than -! X(N-1), followed by points greater than X(N), the extrapolation points -! will be counted (at least) twice in the total returned in IERR. -! -! The evaluation will be most efficient if the elements of XE are -! increasing relative to X; that is, for all J <= K, -! X(I) <= XE(J) -! implies -! X(I) <= XE(K). -! -! If any of the XE are outside the interval [X(1),X(N)], -! values are extrapolated from the nearest extreme cubic, -! and a warning error is returned. -! -! This routine was originally called "PCHFE". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 August 2005 -! -! Author: -! -! Original FORTRAN77 version by Fred Fritsch. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Fred Fritsch, Ralph Carlson, -! Monotone Piecewise Cubic Interpolation, -! SIAM Journal on Numerical Analysis, -! Volume 17, Number 2, April 1980, pages 238-246. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data points. N must be -! at least 2. -! -! Input, real ( kind = 8 ) X(N), the strictly increasing independent -! variable values. -! -! Input, real ( kind = 8 ) F(N), the function values. -! -! Input, real ( kind = 8 ) D(N), the derivative values. -! -! Input, integer ( kind = 4 ) NE, the number of evaluation points. -! -! Input, real ( kind = 8 ) XE(NE), points at which the function is to -! be evaluated. -! -! Output, real ( kind = 8 ) FE(NE), the values of the cubic Hermite -! function at XE. -! - implicit none - - integer ( kind = 4 ) n - integer ( kind = 4 ) ne - - real ( kind = 8 ) d(n) - real ( kind = 8 ) f(n) - real ( kind = 8 ) fe(ne) - integer ( kind = 4 ) i - integer ( kind = 4 ) ierc - integer ( kind = 4 ) ierr - integer ( kind = 4 ) ir - integer ( kind = 4 ) j - integer ( kind = 4 ) j_first - integer ( kind = 4 ) j_new - integer ( kind = 4 ) j_save - integer ( kind = 4 ) next(2) - integer ( kind = 4 ) nj - real ( kind = 8 ) x(n) - real ( kind = 8 ) xe(ne) -! -! Check arguments. -! - if ( n < 2 ) then - ierr = -1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' Number of data points less than 2.' - stop 1 - end if - - do i = 2, n - if ( x(i) <= x(i-1) ) then - ierr = -3 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' X array not strictly increasing.' - stop 1 - end if - end do - - if ( ne < 1 ) then - ierr = -4 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' Number of evaluation points less than 1.' - return - end if - - ierr = 0 -! -! Loop over intervals. -! The interval index is IL = IR-1. -! The interval is X(IL) <= X < X(IR). -! - j_first = 1 - ir = 2 - - do -! -! Skip out of the loop if have processed all evaluation points. -! - if ( ne < j_first ) then - exit - end if -! -! Locate all points in the interval. -! - j_save = ne + 1 - - do j = j_first, ne - if ( x(ir) <= xe(j) ) then - j_save = j - if ( ir == n ) then - j_save = ne + 1 - end if - exit - end if - end do -! -! Have located first point beyond interval. -! - j = j_save - - nj = j - j_first -! -! Skip evaluation if no points in interval. -! - if ( nj /= 0 ) then -! -! Evaluate cubic at XE(J_FIRST:J-1). -! - call chfev ( x(ir-1), x(ir), f(ir-1), f(ir), d(ir-1), d(ir), & - nj, xe(j_first:j-1), fe(j_first:j-1), next, ierc ) - - if ( ierc < 0 ) then - ierr = -5 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' Error return from CHFEV.' - stop 1 - end if -! -! In the current set of XE points, there are NEXT(2) to the right of X(IR). -! - if ( next(2) /= 0 ) then - - if ( ir < n ) then - ierr = -5 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' IR < N.' - stop 1 - end if -! -! These are actually extrapolation points. -! - ierr = ierr + next(2) - - end if -! -! In the current set of XE points, there are NEXT(1) to the left of X(IR-1). -! - if ( next(1) /= 0 ) then -! -! These are actually extrapolation points. -! - if ( ir <= 2 ) then - ierr = ierr + next(1) - else - - j_new = -1 - - do i = j_first, j - 1 - if ( xe(i) < x(ir-1) ) then - j_new = i - exit - end if - end do - - if ( j_new == -1 ) then - ierr = -5 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_PCHIP_VAL - Fatal error!' - write ( *, '(a)' ) ' Could not bracket the data point.' - stop 1 - end if -! -! Reset J. This will be the new J_FIRST. -! - j = j_new -! -! Now find out how far to back up in the X array. -! - do i = 1, ir-1 - if ( xe(j) < x(i) ) then - exit - end if - end do -! -! At this point, either XE(J) < X(1) or X(i-1) <= XE(J) < X(I) . -! -! Reset IR, recognizing that it will be incremented before cycling. -! - ir = max ( 1, i-1 ) - - end if - - end if - - j_first = j - - end if - - ir = ir + 1 - - if ( n < ir ) then - exit - end if - - end do - - return -end -subroutine spline_quadratic_val ( ndata, tdata, ydata, tval, yval, ypval ) - -!*****************************************************************************80 -! -!! SPLINE_QUADRATIC_VAL evaluates a piecewise quadratic spline at a point. -! -! Discussion: -! -! Because of the simple form of a piecewise quadratic spline, -! the raw data points ( TDATA(I), YDATA(I)) can be used directly to -! evaluate the spline at any point. No processing of the data -! is required. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 October 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NDATA, the number of data points defining -! the spline. NDATA should be odd and at least 3. -! -! Input, real ( kind = 8 ) TDATA(NDATA), YDATA(NDATA), the values of -! the independent and dependent variables at the data points. The -! values of TDATA should be distinct and increasing. -! -! Input, real ( kind = 8 ) TVAL, the point at which the spline is to -! be evaluated. -! -! Output, real ( kind = 8 ) YVAL, YPVAL, the value of the spline and -! its first derivative dYdT at TVAL. YPVAL is not reliable if TVAL -! is exactly equal to TDATA(I) for some I. -! - implicit none - - integer ( kind = 4 ) ndata - - real ( kind = 8 ) dif1 - real ( kind = 8 ) dif2 - integer ( kind = 4 ) left - integer ( kind = 4 ) right - real ( kind = 8 ) t1 - real ( kind = 8 ) t2 - real ( kind = 8 ) t3 - real ( kind = 8 ) tdata(ndata) - real ( kind = 8 ) tval - real ( kind = 8 ) y1 - real ( kind = 8 ) y2 - real ( kind = 8 ) y3 - real ( kind = 8 ) ydata(ndata) - real ( kind = 8 ) ypval - real ( kind = 8 ) yval - - if ( ndata < 3 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_QUADRATIC_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA < 3.' - stop 1 - end if - - if ( mod ( ndata, 2 ) == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_QUADRATIC_VAL - Fatal error!' - write ( *, '(a)' ) ' NDATA must be odd.' - stop 1 - end if -! -! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] that contains, or is -! nearest to, TVAL. -! - call r8vec_bracket ( ndata, tdata, tval, left, right ) -! -! Force LEFT to be odd. -! - if ( mod ( left, 2 ) == 0 ) then - left = left - 1 - end if -! -! Copy out the three abscissas. -! - t1 = tdata(left) - t2 = tdata(left+1) - t3 = tdata(left+2) - - if ( t2 <= t1 .or. t3 <= t2 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'SPLINE_QUADRATIC_VAL - Fatal error!' - write ( *, '(a)' ) ' T2 <= T1 or T3 <= T2.' - stop 1 - end if -! -! Construct and evaluate a parabolic interpolant for the data -! in each dimension. -! - y1 = ydata(left) - y2 = ydata(left+1) - y3 = ydata(left+2) - - dif1 = ( y2 - y1 ) / ( t2 - t1 ) - - dif2 = ( ( y3 - y1 ) / ( t3 - t1 ) & - - ( y2 - y1 ) / ( t2 - t1 ) ) / ( t3 - t2 ) - - yval = y1 + ( tval - t1 ) * ( dif1 + ( tval - t2 ) * dif2 ) - ypval = dif1 + dif2 * ( 2.0D+00 * tval - t1 - t2 ) - - return -end -subroutine timestamp ( ) - -!*****************************************************************************80 -! -!! TIMESTAMP prints the current YMDHMS date as a time stamp. -! -! Example: -! -! 31 May 2001 9:45:54.872 AM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 May 2013 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! None -! - implicit none - - character ( len = 8 ) ampm - integer ( kind = 4 ) d - integer ( kind = 4 ) h - integer ( kind = 4 ) m - integer ( kind = 4 ) mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer ( kind = 4 ) n - integer ( kind = 4 ) s - integer ( kind = 4 ) values(8) - integer ( kind = 4 ) y - - call date_and_time ( values = values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end diff --git a/assim/enkf_cf-system2_old/analysisfields_1.in b/assim/enkf_cf-system2_old/analysisfields_1.in deleted file mode 100755 index 2e87d64e..00000000 --- a/assim/enkf_cf-system2_old/analysisfields_1.in +++ /dev/null @@ -1,25 +0,0 @@ -aicen 01 05 i -u 1 53 o -v 1 53 o -dp 1 53 o -temp 1 53 o -saln 1 53 o -uflx 1 53 o -vflx 1 53 o -utflx 1 53 o -vtflx 1 53 o -usflx 1 53 o -vsflx 1 53 o -pb 1 1 o -ub 1 1 o -vb 1 1 o -ubflx 1 1 o -vbflx 1 1 o -ubflxs 1 1 o -vbflxs 1 1 o -ubcors_p 0 0 o -vbcors_p 0 0 o -phi 0 0 o -sealv 0 0 o -ustar 0 0 o -buoyfl 0 0 o diff --git a/assim/enkf_cf-system2_old/assim_build.sh b/assim/enkf_cf-system2_old/assim_build.sh deleted file mode 100755 index 0a224f8b..00000000 --- a/assim/enkf_cf-system2_old/assim_build.sh +++ /dev/null @@ -1,49 +0,0 @@ -#!/bin/sh -e - -# settings used for standalone build -: ${ASSIMROOT:=`readlink -f \`dirname $0\``} -: ${ASSIMCODE_ENKF:=$ASSIMROOT/EnKF} -: ${ASSIMCODE_PREP_OBS:=$ASSIMROOT/prep_obs} -: ${ASSIMCODE_ENSAVE_FIXENKF:=$ASSIMROOT/ensave_fixenkf} -: ${ASSIMCODE_MICOM_INIT:=$ASSIMROOT/micom_init} -: ${SETUPROOT:=../../setup/noresm1} ; . $SETUPROOT/settings/setmach.sh -: ${ANALYSISROOT:=$WORK/noresm/assim_standalone/`basename $ASSIMROOT`} -: ${CLMDAROOT:=$WORK/noresm/clmda_standalone/`basename $ASSIMROOT`} - -# Create folder for CLM -echo + build CLM DA -mkdir -p $CLMDAROOT -cd $CLMDAROOT -cp -f $ASSIMROOT/clmda.sh . -touch DOCLMDA - -echo + build EnKF -mkdir -p $ANALYSISROOT/bld/EnKF/TMP -cd $ANALYSISROOT/bld/EnKF -cp -f $ASSIMROOT/shared/* . -cp -f $ASSIMROOT/EnKF/* . -make clean -make - -echo + build prep_obs -mkdir -p $ANALYSISROOT/bld/prep_obs/TMP -cd $ANALYSISROOT/bld/prep_obs -cp -f $ASSIMROOT/shared/* . -cp -f $ASSIMROOT/prep_obs/* . -make clean -make - -echo + build ensave and fixenkf -mkdir -p $ANALYSISROOT/bld/ensave_fixenkf/TMP -cd $ANALYSISROOT/bld/ensave_fixenkf -cp -f $ASSIMROOT/shared/* . -cp -f $ASSIMROOT/ensave_fixenkf/* . -make clean -make - -echo + build micom_init -mkdir -p $ANALYSISROOT/bld/micom_init -cd $ANALYSISROOT/bld/micom_init -cp -f $ASSIMROOT/micom_init/* . -make clean -make diff --git a/assim/enkf_cf-system2_old/assim_step.sh b/assim/enkf_cf-system2_old/assim_step.sh deleted file mode 120000 index d385a6e7..00000000 --- a/assim/enkf_cf-system2_old/assim_step.sh +++ /dev/null @@ -1 +0,0 @@ -../enkf_cmip6_i1/assim_step.sh \ No newline at end of file diff --git a/assim/enkf_cf-system2_old/clmda.sh b/assim/enkf_cf-system2_old/clmda.sh deleted file mode 100755 index 906ff151..00000000 --- a/assim/enkf_cf-system2_old/clmda.sh +++ /dev/null @@ -1,10 +0,0 @@ -#! /bin/sh -e -rdate=$1 -echo $rdate - -echo LDA_START -echo $LDA_START - -echo rm PAUSE01 -rm PAUSE01 - diff --git a/assim/enkf_cf-system2_old/enkf.prm_1 b/assim/enkf_cf-system2_old/enkf.prm_1 deleted file mode 100755 index 2d700db2..00000000 --- a/assim/enkf_cf-system2_old/enkf.prm_1 +++ /dev/null @@ -1,20 +0,0 @@ -&method - methodtag = "DEnKF" -/ -&ensemble - enssize = 30 -/ -&localisation - locfuntag = "Gaspari-Cohn" - locrad = 1500.0 -/ -&moderation - infl = 1.00 - rfactor1 = XXX - rfactor2 = 4.0 - kfactor = 2.0 -/ -&files -/ -&prmest -/ diff --git a/assim/enkf_cf-system2_old/ensave_fixenkf b/assim/enkf_cf-system2_old/ensave_fixenkf deleted file mode 120000 index 51b98655..00000000 --- a/assim/enkf_cf-system2_old/ensave_fixenkf +++ /dev/null @@ -1 +0,0 @@ -../enkf_cmip6_i1/ensave_fixenkf \ No newline at end of file diff --git a/assim/enkf_cf-system2_old/micom_init b/assim/enkf_cf-system2_old/micom_init deleted file mode 120000 index d7a81c7f..00000000 --- a/assim/enkf_cf-system2_old/micom_init +++ /dev/null @@ -1 +0,0 @@ -../enkf_cmip6_i1/micom_init \ No newline at end of file diff --git a/assim/enkf_cf-system2_old/prep_obs/MODEL.CPP b/assim/enkf_cf-system2_old/prep_obs/MODEL.CPP deleted file mode 100755 index ca007996..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/MODEL.CPP +++ /dev/null @@ -1,4 +0,0 @@ -#undef QMPI -#define ANOMALY -#define LITTLE_ENDIAN -#undef MASK_LANDNEIGHBOUR diff --git a/assim/enkf_cf-system2_old/prep_obs/byteswapper.F90 b/assim/enkf_cf-system2_old/prep_obs/byteswapper.F90 deleted file mode 100755 index 1ad8a971..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/byteswapper.F90 +++ /dev/null @@ -1,48 +0,0 @@ - subroutine swapendian(a) - implicit none - integer(kind=8), intent(inout) :: a ! 4-bytes - - integer(kind=8) ii4, io4 ! 4-bytes - common/czioxe/ ii4, io4 ! helps prevent unwanted optimization - save /czioxe/ - integer(kind=1) ii1(8),io1(8) ! 1-byte - equivalence (ii4,ii1(1)), (io4,io1(1)) ! non-standard f90 - - ii4 = a - io1(1) = ii1(8) - io1(2) = ii1(7) - io1(3) = ii1(6) - io1(4) = ii1(5) - io1(5) = ii1(4) - io1(6) = ii1(3) - io1(7) = ii1(2) - io1(8) = ii1(1) - a = io4 - return - end subroutine swapendian - - subroutine swapendian2(a,n) - implicit none - integer , intent(in) :: n ! Size of input type to convert - - ! NB - input can be anything - can not be compiled with input argument checking - integer(kind=1), intent(inout) :: a(n) - - integer k - integer(kind=1) ii4(16), io4(16) ! 16 bytes should beenough for everyone - !common/czioxe/ ii4, io4 ! helps prevent unwanted optimization - !save /czioxe/ - !integer(kind=1) ii1(16),io1(16) ! 1-byte - !equivalence (ii4(1),ii1(1)), (io4(1),io1(1)) ! non-standard f90 - - ii4(1:n) = a - - do k=1,n - !io1(k) = ii1(n-k+1) - io4(k) = ii4(n-k+1) - end do - - a = io4(1:n) - return - end subroutine swapendian2 - diff --git a/assim/enkf_cf-system2_old/prep_obs/m_get_def_wet_point.F90 b/assim/enkf_cf-system2_old/prep_obs/m_get_def_wet_point.F90 deleted file mode 100755 index bc7ba431..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_get_def_wet_point.F90 +++ /dev/null @@ -1,163 +0,0 @@ -! Bilinear coeffisients are calculated witin this program for all the -! observation points. -! Only wet points are stored in the observation.uf file - -module m_get_def_wet_point - - implicit none - - integer, parameter, private :: STRLEN = 512 - character(STRLEN), parameter, private :: MEANSSHFNAME = "grid.nc" - - private read_mean_ssh - private land_nearby - -contains - - subroutine get_def_wet_point(obs, data, gr, depths, modlat, modlon, nrobs, nx, ny) - ! Program converts to a general format readable by ENKF (observations.uf) - use mod_measurement - use mod_grid - ! Functions to be used - use m_oldtonew - use m_bilincoeff - use m_pivotp_micom - use m_confmap - use m_spherdist - - integer, intent(in) :: nx, ny - type (measurement), intent(in) :: data(:) - type (measurement), intent(inout) :: obs(:) - type (grid), intent(in) :: gr ! observations grid - real, dimension(nx, ny), intent(in) :: depths, modlat, modlon - integer, intent(inout) :: nrobs - integer, parameter :: maxobs = 1441 * 722 !2*400*600 ! maximum number of observations - - real, dimension(nx, ny) :: mean_ssh - integer k, imin, imax, jmin, jmax - integer ipiv, jpiv, nsupport, nsmin, nsmax - integer ipp1,ipm1,jpp1,jpm1 - real :: x0, y0 - real wetsill, griddiag, mingridsize, minobssize - real, dimension(nx,ny) :: min_r, max_r - integer, dimension(nx,ny) :: itw, jtw, its, jts, itn, jtn, ite, jte - - logical wet - - nrobs = 0; - nsmin = maxobs; - nsmax = 0 - mingridsize = 1.E+10; - minobssize = 1.E+10 ! in meters - call ini_pivotp(modlon,modlat, nx, ny, min_r, max_r, itw, jtw, itn, jtn, its, jts, ite, jte) - ipiv=1 - jpiv=1 - - - !Calculate pivot points - !Find wet points (all neigbours in water) - !Find the points with defined data value - !Put the data into the obs data structture - !Compute bilinear coefficients - - - - do k = 1, gridpoints(gr) - if (data(k) % id .eq. 'SLA' .or. data(k) % id .eq. 'sla' .or. & - data(k)%id.eq.'TSLA') then - call read_mean_ssh(mean_ssh, nx, ny) - wetsill = 200. ! Discarding data in shallow waters - elseif (data(k) % id.eq. 'SSH' .or. data(k)%id .eq. 'ssh') then - wetsill = 200. ! Discarding data in shallow waters - else - wetsill=10. - endif - call pivotp_micom(data(k)%lon, data(k)%lat, modlon, modlat, ipiv, jpiv, & - nx, ny, min_r, max_r,itw, jtw, itn, jtn, its, jts, ite, jte) -#ifdef MASK_LANDNEIGHBOUR - ipm1=max(ipiv-1,1) - ipp1=min(ipiv+1,nx) - jpm1=max(jpiv-1,1) - jpp1=min(jpiv+1,ny) - if (any(depths(ipm1:ipp1, jpm1:jpp1) < wetsill) ) cycle -#endif - if (depths(ipiv, jpiv) < wetsill ) cycle - wet = data(k) % status ! Discards inconsistent/Fill values - if (data(k) % id .eq. 'SLA' .or. data(k) % id .eq. 'sla' .or.& - data(k) % id .eq. 'TSLA') then - wet = wet .and. (mean_ssh(ipiv, jpiv) < 990) - wet = wet .and. .not. land_nearby(nx, ny, mean_ssh, modlon, modlat,& - ipiv, jpiv, data(k) % lon, data(k) % lat) - endif - - if(.not. undefined(data(k) % d, gr) .and. wet) then - - nrobs = nrobs + 1 - obs(nrobs) = data(k) - obs(nrobs) % ipiv = ipiv - obs(nrobs) % jpiv= jpiv - obs(nrobs) % status = .true. ! Wet obs - obs(nrobs) % ns = 0 ! point measurements have zero support - if (trim(obs(nrobs)%id) .eq. 'SST') then - !Fanf: Really try to avoid localisation (only assimilate the vert - !profile). - obs(nrobs) % lon = modlon(ipiv,jpiv) ! point measurements have zero support - obs(nrobs) % lat = modlat(ipiv,jpiv) ! point measurements have zero support - endif - endif - end do - print*, 'Number of defined and wet observations: nrobs ', nrobs - print*, 'Support (in nb of cells) between: ', nsmin, ' and ', nsmax - print '(2(a,f8.3),a)', ' Minimum obs support: ', 0.001 * minobssize, & - 'km, min grid diagonal: ', 0.001 * mingridsize, ' km' - end subroutine get_def_wet_point - - - subroutine read_mean_ssh(mean_ssh, nx, ny) - use nfw_mod - - integer, intent(in) :: nx, ny - real, intent(out):: mean_ssh(nx, ny) - - logical :: exists - integer :: ncid, vSSH_ID - - inquire(file = trim(MEANSSHFNAME), exist = exists) - if (.not. exists) then - print *,'ERROR: read_mean_ssh(): file "', trim(MEANSSHFNAME), '" not found' - stop - end if - - call nfw_open(trim(MEANSSHFNAME), nf_nowrite, ncid) - call nfw_inq_varid(trim(MEANSSHFNAME), ncid, 'pdepth', vSSH_ID) - call nfw_get_var_double(trim(MEANSSHFNAME), ncid, vSSH_ID, mean_ssh) - call nfw_close(trim(MEANSSHFNAME), ncid) - - end subroutine read_mean_ssh - - - logical function land_nearby(nx, ny, mean_ssh, modlon, modlat, ipiv, jpiv, obslon, obslat) - use m_spherdist - implicit none - real, parameter :: Dis0 = 50.0d0 - integer, intent (in) :: nx, ny, ipiv, jpiv - real, dimension(nx,ny), intent(in) :: mean_ssh, modlon, modlat - real, intent (in) :: obslon,obslat - integer :: ii, jj, ncells - real :: griddist - - land_nearby = .false. - ncells = ceiling(Dis0 / spherdist(modlon(ipiv, jpiv), modlat(ipiv, jpiv),& - modlon(ipiv, jpiv + 1), modlat(ipiv, jpiv + 1))) - do jj = max(jpiv - ncells, 1), min(jpiv + ncells, ny) - do ii = max(ipiv - ncells, 1), min(ipiv + ncells, nx) - griddist = spherdist(modlon(ii, jj), modlat(ii, jj), obslon, obslat) - if (mean_ssh(ipiv,jpiv) < 990 .and. griddist < Dis0) then - land_nearby = .true. - return - end if - enddo - enddo - end function land_nearby - -end module m_get_def_wet_point diff --git a/assim/enkf_cf-system2_old/prep_obs/m_nf90_err.F90 b/assim/enkf_cf-system2_old/prep_obs/m_nf90_err.F90 deleted file mode 100755 index d38988ea..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_nf90_err.F90 +++ /dev/null @@ -1,25 +0,0 @@ -module m_nf90_err -contains - - subroutine nf90_err(errcode,chars) - use netcdf - implicit none - integer, intent(in) :: errcode - character(len=*), optional :: chars - character(len=80) :: hint - - - hint ='' - if (present(chars)) hint=chars - - - if (errcode/=NF90_NOERR) then - write(6,'(a)') NF90_STRERROR(errcode)//' '//trim(hint) - stop '(handle_err)' - end if - - end subroutine - - - -end module m_nf90_err diff --git a/assim/enkf_cf-system2_old/prep_obs/m_pivotp_micom.F90 b/assim/enkf_cf-system2_old/prep_obs/m_pivotp_micom.F90 deleted file mode 100755 index 98915c47..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_pivotp_micom.F90 +++ /dev/null @@ -1,398 +0,0 @@ -module m_pivotp_micom - use netcdf - use nfw_mod - use m_spherdist - implicit none - -contains - ! F. Counillon (adapted from an algorithm of Mats Bentsen) - ! This subroutine search the pivot point for a given observations - ! The search is linear moving toward the neigboring grid cell that minimize - ! the distance to the obs. This search is in the worst case in O(n). The input - ! ipiv, jpiv corresponds to the pivot point from the previous search. If there - ! is a kind of order in the way the observation are given the search will be - ! very fast. - ! - subroutine pivotp_micom(lon, lat,modlon,modlat, ipiv, jpiv, nx, ny, min_r, max_r, & - itw, jtw, its, jts, itn, jtn, ite, jte) - real, intent(in) :: lon, lat - integer, intent(in) :: nx, ny - real, intent(in), dimension(nx,ny) :: modlon,modlat, min_r, max_r - integer, intent(in), dimension(nx,ny) :: itw,jtw, & - its, jts, itn, jtn, ite, jte - integer, intent(inout) :: ipiv, jpiv - real*8 :: min_d, d - integer :: i, j, ito, jto - - min_d = spherdist(modlon(ipiv,jpiv), modlat(ipiv,jpiv), lon, lat) - do while (min_d > min_r(ipiv,jpiv)) - - ito = ipiv - jto = jpiv - - i = itw(ito,jto) - j = jtw(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - i = ite(ito,jto) - j = jte(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - i = its(ito,jto) - j = jts(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - i = itn(ito,jto) - j = jtn(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - - if (ipiv == ito .and. jpiv == jto) exit - - enddo -end subroutine pivotp_micom - - -! Y. WANG (adapted from an algorithm of F. COUNILLON) -! This subroutine search the pivot point for a given observation -! The search is linear moving toward the neigboring grid cell that minimize -! -subroutine pivotp_micom_new(lon, lat,modlon,modlat, ipiv, jpiv, nx, ny, min_r, max_r, & - itw, jtw, itn, jtn, its, jts, ite, jte) - real, intent(in) :: lon, lat - integer, intent(in) :: nx, ny - real, intent(in), dimension(nx,ny) :: modlon,modlat, min_r, max_r - integer, intent(in), dimension(nx,ny) :: itw,jtw, & - its, jts, itn, jtn, ite, jte - integer, intent(inout) :: ipiv, jpiv - real*8 :: min_d, d - integer :: i, j, ito, jto - - real :: xx(4), yy(4) - logical :: inside - - min_d = spherdist(modlon(ipiv,jpiv), modlat(ipiv,jpiv), lon, lat) - do while (min_d > min_r(ipiv,jpiv)) - - ito = ipiv - jto = jpiv - - i = itw(ito,jto) - j = jtw(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - - i = ite(ito,jto) - j = jte(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - - i = its(ito,jto) - j = jts(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - - i = itn(ito,jto) - j = jtn(ito,jto) - d = spherdist(modlon(i,j), modlat(i,j), lon, lat) - if (d.lt.min_d) then - ipiv = i - jpiv = j - min_d = d - endif - - if (ipiv == ito .and. jpiv == jto) exit - - enddo - - ito = ipiv - jto = jpiv - if (jpiv == ny) then - ! check two grids - i = ito - j = jto - xx(1) = modlon(i, j) - xx(2) = modlon(itw(i,j), jtw(i,j)) - xx(3) = modlon(its(itw(i,j), jtw(i,j)), jts(itw(i,j), jtw(i,j))) - xx(4) = modlon(its(i,j), jts(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(itw(i,j), jtw(i,j)) - yy(3) = modlat(its(itw(i,j), jtw(i,j)), jts(itw(i,j), jtw(i,j))) - yy(4) = modlat(its(i,j), jts(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = its(itw(i,j), jtw(i,j)) - jpiv = jts(itw(i,j), jtw(i,j)) - return - end if - xx(1) = modlon(i, j) - xx(2) = modlon(ite(i,j), jte(i,j)) - xx(3) = modlon(its(ite(i,j), jte(i,j)), jts(ite(i,j), jte(i,j))) - xx(4) = modlon(its(i,j), jts(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(ite(i,j), jte(i,j)) - yy(3) = modlat(its(ite(i,j), jte(i,j)), jts(ite(i,j), jte(i,j))) - yy(4) = modlat(its(i,j), jts(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = its(i,j) - jpiv = jts(i,j) - return - else - jpiv = ny - end if - else if (jpiv > 1) then - ! check four gird - i = ito - j = jto - - ! check north-east - xx(1) = modlon(i, j) - xx(2) = modlon(ite(i,j), jte(i,j)) - xx(3) = modlon(itn(ite(i,j), jte(i,j)), jtn(ite(i,j), jte(i,j))) - xx(4) = modlon(itn(i,j), jtn(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(ite(i,j), jte(i,j)) - yy(3) = modlat(itn(ite(i,j), jte(i,j)), jtn(ite(i,j), jte(i,j))) - yy(4) = modlat(itn(i,j), jtn(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = i - jpiv = j - return - end if - ! check south-west - xx(1) = modlon(i, j) - xx(2) = modlon(itw(i,j), jtw(i,j)) - xx(3) = modlon(its(itw(i,j), jtw(i,j)), jts(itw(i,j), jtw(i,j))) - xx(4) = modlon(its(i,j), jts(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(itw(i,j), jtw(i,j)) - yy(3) = modlat(its(itw(i,j), jtw(i,j)), jts(itw(i,j), jtw(i,j))) - yy(4) = modlat(its(i,j), jts(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = its(itw(i,j), jtw(i,j)) - jpiv = jts(itw(i,j), jtw(i,j)) - return - end if - ! check south-east - xx(1) = modlon(i, j) - xx(2) = modlon(ite(i,j), jte(i,j)) - xx(3) = modlon(its(ite(i,j), jte(i,j)), jts(ite(i,j), jte(i,j))) - xx(4) = modlon(its(i,j), jts(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(ite(i,j), jte(i,j)) - yy(3) = modlat(its(ite(i,j), jte(i,j)), jts(ite(i,j), jte(i,j))) - yy(4) = modlat(its(i,j), jts(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = its(i,j) - jpiv = jts(i,j) - return - end if - ! check north-west - xx(1) = modlon(i, j) - xx(2) = modlon(itw(i,j), jtw(i,j)) - xx(3) = modlon(itn(itw(i,j), jtw(i,j)), jtn(itw(i,j), jtw(i,j))) - xx(4) = modlon(itn(i,j), jtn(i,j)) - yy(1) = modlat(i, j) - yy(2) = modlat(itw(i,j), jtw(i,j)) - yy(3) = modlat(itn(itw(i,j), jtw(i,j)), jtn(itw(i,j), jtw(i,j))) - yy(4) = modlat(itn(i,j), jtn(i,j)) - call check_point(lon,lat,xx,yy,inside) - if (inside) then - ipiv = itw(i,j) - jpiv = jtw(i,j) - return - else - print *, 'ERROR: pivotp_micom_new()', ipiv, jpiv - print *, lon, lat - stop - end if - else - return - end if -end subroutine pivotp_micom_new - -subroutine ini_pivotp(modlon,modlat, nx, ny, min_r, max_r, itw, jtw, itn, jtn, its, jts, ite, jte) - integer, intent(in) :: nx, ny - real, intent(in), dimension(nx,ny) :: modlon,modlat - real, intent(out), dimension(nx,ny):: min_r, max_r - integer, intent(out), dimension(nx,ny) :: itw, jtw, & - itn, jtn, its, jts, ite, jte - integer :: ncid,vITW_ID, vJTW_ID, vITE_ID ,vJTE_ID ,vITS_ID, & - vJTS_ID, vITN_ID, vJTN_ID, vVCLON_ID, vVCLAT_ID, vUCLON_ID & - , vUCLAT_ID, vTCLON_ID, vTCLAT_ID ,ii,jj - - real, dimension(nx,ny,4) :: vclon, vclat, uclon, uclat, tclon, tclat - call nfw_open('grid.nc', nf_nowrite, ncid) - - call nfw_inq_varid('grid.nc', ncid,'inw' ,vITW_ID) - call nfw_inq_varid('grid.nc', ncid,'jnw' ,vJTW_ID) - call nfw_inq_varid('grid.nc', ncid,'ine' ,vITE_ID) - call nfw_inq_varid('grid.nc', ncid,'jne' ,vJTE_ID) - call nfw_inq_varid('grid.nc', ncid,'ins' ,vITS_ID) - call nfw_inq_varid('grid.nc', ncid,'jns' ,vJTS_ID) - call nfw_inq_varid('grid.nc', ncid,'inn' ,vITN_ID) - call nfw_inq_varid('grid.nc', ncid,'jnn' ,vJTN_ID) - call nfw_inq_varid('grid.nc', ncid,'vclon' ,vVCLON_ID) - call nfw_inq_varid('grid.nc', ncid,'vclat' ,vVCLAT_ID) - call nfw_inq_varid('grid.nc', ncid,'uclon' ,vUCLON_ID) - call nfw_inq_varid('grid.nc', ncid,'uclat' ,vUCLAT_ID) - call nfw_inq_varid('grid.nc', ncid,'pclon' ,vTCLON_ID) - call nfw_inq_varid('grid.nc', ncid,'pclat' ,vTCLAT_ID) - call nfw_get_var_int('grid.nc', ncid, vITW_ID, itw) - call nfw_get_var_int('grid.nc', ncid, vJTW_ID, jtw) - call nfw_get_var_int('grid.nc', ncid, vITS_ID, its) - call nfw_get_var_int('grid.nc', ncid, vJTS_ID, jts) - call nfw_get_var_int('grid.nc', ncid, vITN_ID, itn) - call nfw_get_var_int('grid.nc', ncid, vJTN_ID, jtn) - call nfw_get_var_int('grid.nc', ncid, vITE_ID, ite) - call nfw_get_var_int('grid.nc', ncid, vJTE_ID, jte) - call nfw_get_var_double('grid.nc', ncid, vVCLON_ID, vclon) - call nfw_get_var_double('grid.nc', ncid, vVCLAT_ID, vclat) - call nfw_get_var_double('grid.nc', ncid, vUCLON_ID, uclon) - call nfw_get_var_double('grid.nc', ncid, vUCLAT_ID, uclat) - call nfw_get_var_double('grid.nc', ncid, vTCLON_ID, tclon) - call nfw_get_var_double('grid.nc', ncid, vTCLAT_ID, tclat) - do jj = 1, ny - do ii = 1, nx - min_r(ii,jj) = & - min(spherdist(vclon(ii,jj,4), vclat(ii,jj,4), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(vclon(ii,jj,3), vclat(ii,jj,3), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(uclon(ii,jj,2), uclat(ii,jj,2), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(uclon(ii,jj,3), uclat(ii,jj,3), & - modlon(ii,jj), modlat(ii,jj))) - max_r(ii,jj) = & - max(spherdist(tclon(ii,jj,1), tclat(ii,jj,1), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(tclon(ii,jj,2), tclat(ii,jj,2), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(tclon(ii,jj,3), tclat(ii,jj,3), & - modlon(ii,jj), modlat(ii,jj)), & - spherdist(tclon(ii,jj,4), tclat(ii,jj,4), & - modlon(ii,jj), modlat(ii,jj))) - enddo - enddo -end subroutine ini_pivotp - -! Y. WANG: check if point in model grid (irregulaer four points) -subroutine check_point(x, y, xx, yy, inside) - real, intent(in) :: x, y - real, intent(in) :: xx(4), yy(4) - logical, intent(inout) :: inside - ! distance between (xx(i), yy(i)) and (x,y) - real :: a, b, c - ! semi-parameter - real :: s - ! area - real :: sum_triangle_area - real :: rectangle_area - - ! initialasation - inside = .false. - sum_triangle_area = 0. - rectangle_area = 0. - - ! first trangle area with (xx(1), yy(1)), (xx(2), yy(2)) and (x,y) - a = periodic_sqrt(xx(1), yy(1), x, y) - b = periodic_sqrt(xx(2), yy(2), x, y) - c = periodic_sqrt(xx(1), yy(1), xx(2), yy(2)) - s = (a + b + c) / 2 - sum_triangle_area = sum_triangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - ! second trangle area with (xx(2), yy(2)), (xx(3), yy(3)) and (x,y) - a = periodic_sqrt(xx(3), yy(3), x, y) - b = periodic_sqrt(xx(2), yy(2), x, y) - c = periodic_sqrt(xx(3), yy(3), xx(2), yy(2)) - s = (a + b + c) / 2 - sum_triangle_area = sum_triangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - ! third trangle area with (xx(3), yy(3)), (xx(4), yy(4)) and (x,y) - a = periodic_sqrt(xx(3), yy(3), x, y) - b = periodic_sqrt(xx(4), yy(4), x, y) - c = periodic_sqrt(xx(3), yy(3), xx(4), yy(4)) - s = (a + b + c) / 2 - sum_triangle_area = sum_triangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - ! fourth trangle area with (xx(1), yy(1)), (xx(4), yy(4)) and (x,y) - a = periodic_sqrt(xx(1), yy(1), x, y) - b = periodic_sqrt(xx(4), yy(4), x, y) - c = periodic_sqrt(xx(1), yy(1), xx(4), yy(4)) - s = (a + b + c) / 2 - sum_triangle_area = sum_triangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - ! rectangle area = triangle_area((xx(1),yy(1)), (xx(2),yy(2)), (xx(3),yy(3))) - ! + triangle_area((xx(1),yy(1)), (xx(4),yy(4)), (xx(3),yy(3))) - a = periodic_sqrt(xx(1), yy(1), xx(2), yy(2)) - b = periodic_sqrt(xx(2), yy(2), xx(3), yy(3)) - c = periodic_sqrt(xx(1), yy(1), xx(3), yy(3)) - s = (a + b + c) / 2 - rectangle_area = rectangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - a = periodic_sqrt(xx(1), yy(1), xx(4), yy(4)) - b = periodic_sqrt(xx(4), yy(4), xx(3), yy(3)) - c = periodic_sqrt(xx(1), yy(1), xx(3), yy(3)) - s = (a + b + c) / 2 - rectangle_area = rectangle_area + sqrt(s*(s-a)*(s-b)*(s-c)) - - if (abs(rectangle_area - sum_triangle_area) < 1e-6) then - inside = .true. - end if -end subroutine check_point - -! Y. WANG: calculate the distance of two points -! e.g. for two points (179 W, 0 N) and (-179 W, 0N) -! sqrt = 358**(1/2) -! periodic_sqrt = 2**(1/2) -! -function periodic_sqrt(lon1,lat1,lon2,lat2) - - real periodic_sqrt - real, intent (in) :: lon1,lat1,lon2,lat2 - - ! local - real :: tmp - - ! longitude is a periodic function - tmp = abs(lon1 - lon2) - ! smaller difference - tmp = min(tmp, 360 - tmp) - - periodic_sqrt = sqrt(tmp**2 + (lat1 - lat2)**2) - -end function periodic_sqrt - -end module m_pivotp_micom diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CERSAT_data.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CERSAT_data.F90 deleted file mode 100755 index 8a783190..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CERSAT_data.F90 +++ /dev/null @@ -1,191 +0,0 @@ -module m_read_CERSAT_data - -contains - - subroutine read_CERSAT_data(driftfile, gr, data, numdata, var) - use nfw_mod - use mod_measurement - use mod_grid - use m_spherdist - implicit none - - character(*), intent(in) :: driftfile - integer, intent(in) :: numdata - type(measurement), dimension(numdata) :: data - type(grid), intent(in) :: gr - real, intent(in) :: var - - integer :: dimids(2) - integer , dimension(2) :: dimsizes - - integer :: lon_id, lat_id, zon_id, mer_id, qua_id - real, dimension(:,:), allocatable :: drlon, drlat, drmer, drzon - integer, dimension(:,:), allocatable :: qflag - - integer :: ncid, varid - real, dimension(1) :: scalefac, fillval, addoffset - - integer :: i,j,k,icomp - integer :: drnx, drny - logical :: valid - integer :: tmpint, bit(0:8) - - ! Get dimensions of drift file - call nfw_open(driftfile, nf_nowrite, ncid) - call nfw_inq_varid(driftfile, ncid, 'zonal_motion', varid) - call nfw_inq_vardimid(driftfile, ncid, varid, dimids) - do i = 1, 2 - call nfw_inq_dimlen(driftfile, ncid, dimids(i), dimsizes(i)) - end do - - if (gr % reg) then - print *,'NB: CERSAT data should be specified as irregular !' - print *,' Currently it is set as regular..' - print *,'(read_CERSAT_data)' - call exit(1) - end if - - ! Which should match numdata dimension - ! NB !!! Mult by 2 for two vector components - if (2 * dimsizes(1) * dimsizes(2) /= numdata .or. & - gr % nx /= dimsizes(1) * dimsizes(2) * 2) then - print *,'Different dimensions - data file and specified' - print *,'dimsizes(1)=',dimsizes(1) - print *,'dimsizes(2)=',dimsizes(2) - print *,'nx =',gr%nx - print *,'(read_CERSAT_data)' - call exit(1) - end if - - ! Read data from drift file - drnx=dimsizes(1) - drny=dimsizes(2) - allocate(drlon(drnx,drny)) - allocate(drlat(drnx,drny)) - allocate(drmer(drnx,drny)) - allocate(drzon(drnx,drny)) - allocate(qflag(drnx,drny)) - call nfw_inq_varid(driftfile, ncid, 'longitude', lon_id) - !call nfw_get_var_double(driftfile, ncid, lon_id, drlon) - call cersat_readfield(driftfile, ncid, lon_id, drlon, drnx * drny) - call nfw_inq_varid(driftfile, ncid, 'latitude', lat_id) - !call nfw_get_var_double(driftfile, ncid, lat_id, drlat) - call cersat_readfield(driftfile, ncid, lat_id, drlat, drnx * drny) - call nfw_inq_varid(driftfile, ncid, 'zonal_motion', zon_id) - !call nfw_get_var_double(driftfile, ncid, zon_id, drzon) - call cersat_readfield(driftfile, ncid, zon_id, drzon, drnx * drny) - call nfw_inq_varid(driftfile, ncid, 'meridional_motion', mer_id) - !call nfw_get_var_double(driftfile, ncid, mer_id, drmer) - call cersat_readfield(driftfile, ncid, mer_id, drmer, drnx * drny) - - call nfw_get_att_double(driftfile, ncid, zon_id, '_FillValue', fillval) - call nfw_get_att_double(driftfile, ncid, zon_id, 'scale_factor', scalefac) - call nfw_get_att_double(driftfile, ncid, zon_id, 'add_offset', addoffset) - - where (abs(drzon - (fillval(1) * scalefac(1) + addoffset(1))) <& - 1e-4 * fillval(1) * scalefac(1) + addoffset(1)) - drzon = gr % undef - end where - - call nfw_get_att_double(driftfile, ncid, mer_id, '_FillValue', fillval) - call nfw_get_att_double(driftfile, ncid, mer_id, 'scale_factor', scalefac) - call nfw_get_att_double(driftfile, ncid, mer_id, 'add_offset', addoffset) - - ! Flag zonal motion for fill values - where (abs(drmer - (fillval(1) * scalefac(1) + addoffset(1))) <& - 1e-4 * fillval(1) * scalefac(1) + addoffset(1)) - drmer = gr % undef - end where - - call nfw_inq_varid(driftfile, ncid, 'quality_flag', qua_id) - call nfw_get_var_int(driftfile, ncid, qua_id, qflag) - - call nfw_close(driftfile, ncid) - - k = 0 - do icomp = 1, 2 - do j = 1, drny ! gr%ny - do i = 1, drnx ! gr%nx - k = k + 1 - - ! Qualit flag bits - may be signed - tmpint = qflag(i,j) - bit(7) = tmpint/128; tmpint = tmpint - bit(7)*128 ! Not used - bit(6) = tmpint/ 64; tmpint = tmpint - bit(6)* 64 ! Validated using all available info - bit(5) = tmpint/ 32; tmpint = tmpint - bit(5)* 32 ! Validated using local consistency - bit(4) = tmpint/ 16; tmpint = tmpint - bit(4)* 16 ! Cost function used - bit(3) = tmpint/ 8; tmpint = tmpint - bit(3)* 8 ! Two identical drift vectors - bit(2) = tmpint/ 4; tmpint = tmpint - bit(2)* 4 ! SSMI V selected - bit(1) = tmpint/ 2; tmpint = tmpint - bit(1)* 2 ! SSMI H used - bit(0) = tmpint/ 1; tmpint = tmpint - bit(0)* 1 ! Quickscat used - - valid = qflag(i,j) < 127 ! Intermediate solution until I figure out the byte stuff - if (icomp==1) then - data(k)%id = 'VICE' - data(k)%d = drmer(i,j)*.001 ! Convert to km - valid = valid .and. abs( (drmer(i,j)-gr%undef) / gr%undef) > 1e-4 - else - data(k)%id = 'UICE' - data(k)%d = drzon(i,j)*.001 ! Convert to km - valid = valid .and. abs( (drzon(i,j)-gr%undef) / gr%undef) > 1e-4 - end if - - if (.not.valid) then - data(k)%d = gr%undef - end if - - data(k)%ipiv = i ! Not really used for ice drift - data(k)%jpiv = j ! Not really used for ice drift - data(k)%i_orig_grid = i ! Used for ice drift - data(k)%j_orig_grid = j ! Used for ice drift - data(k)%lat=drlat(i,j) - data(k)%lon=ang180(drlon(i,j)) - !LB: Data support is assumed = a square grid cell - !support diameter in meters stored in %a1 (tricky, isn't it ?) - ! KAL -- hardcoded from data - data(k)%a1 = 1.4 * 16000.0 - data(k)%ns = 1 - ! To be decided - obs units are meters O(1e4) - ! CERSAT grid cells are of ~30 km - We assume the errors are - ! roughly ~15 km - !KAL data(k)%var = (15)**2 - data(k)%var = var ! fom idrft.hdr specification - data(k)%depth = 0.0 - data(k)%status = valid - enddo - enddo - enddo - print*, 'Number of data read:', k, gridpoints(gr) - - print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - print *,'!!!!!!!!! Adjust obs errors !!!!!!!!!!!!!!!!!!!' - print *,'!!!!!!!Use qflag in valid as well!!!!!!!!!!!!!!!' - print *,'!!!!!!!!!!CHECK use of qflag !!!!!!!!!!!!!!!!!!!' - print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - end subroutine read_CERSAT_data - - - subroutine cersat_readfield(fname, ncid, varid, v, vlen) - use nfw_mod - implicit none - - character*(*), intent(in) :: fname - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in):: vlen - real(8), intent(out) :: v(vlen) - - real(8) :: scale_factor(1) - real(8) :: offset(1) - - call nfw_get_att_double(fname, ncid, varid, 'scale_factor', scale_factor) - call nfw_get_att_double(fname, ncid, varid, 'add_offset', offset) - call nfw_get_var_double(fname, ncid, varid, v) - v = v * scale_factor(1) + offset(1) - end subroutine cersat_readfield - -end module m_read_CERSAT_data - - diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SLA.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SLA.F90 deleted file mode 100755 index 5042be13..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SLA.F90 +++ /dev/null @@ -1,133 +0,0 @@ -module m_read_CLS_SLA -! Reads CLS SLA data after having read the grid in read_CLS_SST_grid - contains - - subroutine read_CLS_SLA(fname,gr,data) - use mod_measurement - use mod_grid - use m_spherdist - use netcdf - use m_nf90_err - implicit none - - type (measurement), intent(inout) :: data(:) - type (grid), intent(inout) :: gr ! CLS measurement grid - character(len=80), intent(in) :: fname - -!dimension ids - integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID - -! Variable ids - integer :: vNbLatitudes_ID, vNbLongitudes_ID, vGrid0001_ID - -! Array dimensions - integer :: LatLon, NbLatitudes, NbLongitudes - -! Data arrays - real,allocatable :: sla(:,:), lon(:),lat(:) - -! utilitary - integer ncid, ijmax(2) - real undef,undef_lat, undef_lon - integer i, j,k - logical valid - real, parameter :: eps = 0.01 ! test for undefined values - -! Open file -! filename='sst_topaz_19510.nc' - call nf90_err(NF90_OPEN(trim(fname),NF90_NOCLOBBER,ncid)) - !call nfw_open(trim(fname), nf_nowrite, ncid) - -! Get dimension id in netcdf file ... - call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID)) - -! Get dimension length from id - call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes)) - print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon - -! State which variable you want here.. Available vars are shown when you do -! "ncdump -h " on the netcdf file. This is for SSH - allocate(lon(NbLongitudes)) - allocate(lat(NbLatitudes)) - allocate(sla(NbLatitudes,NbLongitudes)) - -! Variable ids in netcdf file - call nf90_err(nf90_inq_varid(ncid,'NbLatitudes' ,vNbLatitudes_ID),'NbLatitudes') - call nf90_err(nf90_inq_varid(ncid,'NbLongitudes' ,vNbLongitudes_ID),'NbLongitudes') - call nf90_err(nf90_inq_varid(ncid,'Grid_0001' ,vGrid0001_ID),'Grid_0001') - -! Variable _FillValue attributes - call nf90_err(nf90_get_att(ncid,vNbLatitudes_ID , '_FillValue',undef_lat)) - call nf90_err(nf90_get_att(ncid,vNbLongitudes_ID ,'_FillValue',undef_lon)) - call nf90_err(nf90_get_att(ncid,vGrid0001_ID , '_FillValue',undef)) - print*, 'Undefined values are ', undef_lat, undef_lon, undef - gr%undef = undef - -! actual variable values (for dimensions of var -- see ncdump, or improve this program) -! NB: note that index dimensions are different between fortran and C internals. -! "ncdump" gives C internals. - print *,'test' - call nf90_err(nf90_get_var(ncid,vNbLongitudes_ID ,lon)) - !lon = ang180(lon) - print *,'Range Lon', minval(lon), maxval(lon) - call nf90_err(nf90_get_var(ncid,vNbLatitudes_ID ,lat)) - print *,'Range Lat', minval(lat), maxval(lat) - call nf90_err(nf90_get_var(ncid,vGrid0001_ID ,sla)) - print *,'Range SLA in cm ', minval(sla), maxval(sla) - - print '(4a10)','Lat','Lon','SLA[cm]' - ijmax = minloc(sla) - do i=ijmax(1)-5, ijmax(1)+5 - j = ijmax(2) - print '(4f10.3)', lat(i), lon(j), sla(i,j) - enddo - - call nf90_err (nf90_close(ncid)) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Fill the data(:) vector - - do j=1,NbLongitudes ! gr%ny - do i=1,NbLatitudes ! gr%nx - k=(j-1)*gr%nx+i - - data(k)%id = 'SLA' - data(k)%d = sla(i,j) * 0.01 ! Conversion to meters - - data(k)%ipiv = i - data(k)%jpiv = j - - data(k)%lat=lat(i) - data(k)%lon=ang180(lon(j)) - -!LB: Data support is assumed = a square grid cell -!support diameter in meters stored in %a1 (tricky, isn't it ?) - data(k)%a1 = spherdist(lon(j)-.5*gr%dx,lat(i)-.5*gr%dy, & - lon(j)+.5*gr%dx,lat(i)+.5*gr%dy) - data(k)%ns = 1 - - !data(k)%var = 0.01 ! 30cm temporarily, 10 cm by default - !PS - data(k)%var = 0.001 ! 30cm temporarily, 10 cm by default - - data(k)%depth = 0.0 - - valid = (abs( (lon(j)-undef_lon) / undef_lon ) > eps & - .and. abs( (lat(i)-undef_lat) / undef_lat ) > eps & - .and. abs( (sla(i,j)-undef) / undef ) > eps ) - - data(k)%status = valid - - enddo - enddo - print*, 'Number of data read:', k, gridpoints(gr) - - deallocate(lat,lon,sla) - -end subroutine read_CLS_SLA - -end module m_read_CLS_SLA diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SSH.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SSH.F90 deleted file mode 100755 index d7d7e2f6..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SSH.F90 +++ /dev/null @@ -1,139 +0,0 @@ -module m_read_CLS_SSH - -contains - - subroutine read_CLS_SSH(fname,data,modlon,modlat,depths,dlon,dlat,nrobs,nx,ny) - use mod_measurement - use m_pivotp_micom - use mod_grid - use nfw_mod - - implicit none - - integer, intent(in) :: nx, ny - integer, intent(in) :: dlon,dlat - integer, intent(out) :: nrobs - type (measurement), intent(inout) :: data(:) - real, dimension(nx,ny), intent(in) :: depths,modlon,modlat - character(len=80), intent(in) :: fname - - integer :: vLON_ID,vLAT_ID - integer :: ncid,vSSH_ID,i,j,k - integer :: irec - integer :: ipiv, jpiv - integer :: ipp1,ipm1,jpp1,jpm1 - integer, dimension(nx,ny) :: itw, jtw, its, jts, itn, jtn, ite, jte - - logical :: ex, wet - - real :: lon, lat,ssh,ssh_sq, wetsill - real, dimension(nx,ny) :: min_r, max_r, obs_unc - real(4), dimension(1) :: scalefac, addoffset, fillvalue, fillvalue2 - real(4), allocatable :: vssh(:,:,:,:), vssh2(:,:,:,:) - real , allocatable :: vlongitude(:), vlatitude(:) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call ini_pivotp(modlon,modlat, nx, ny, min_r, max_r, itw, jtw, itn, jtn, its, jts, ite, jte) - ipiv=1 - jpiv=1 - - ! Read observation file - allocate(vssh(dlon,dlat,1,1)) - allocate(vlongitude(dlon)) - allocate(vlatitude(dlat)) - - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'Data file ', fname, ' not found.' - stop - end if - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_varid(fname, ncid,'height', vSSH_ID) - call nfw_inq_varid(fname, ncid,'lon', vLON_ID) - call nfw_inq_varid(fname, ncid,'lat', vLAT_ID) - call nfw_get_var_real(fname, ncid, vSSH_ID, vssh) - call nfw_get_var_double(fname, ncid, vLON_ID, vlongitude) - call nfw_get_var_double(fname, ncid, vLAT_ID, vlatitude) - call nfw_get_att_real(fname, ncid, vSSH_ID, 'add_offset', addoffset) - call nfw_get_att_real(fname, ncid, vSSH_ID, 'scale_factor', scalefac) - call nfw_get_att_real(fname, ncid, vSSH_ID, '_FillValue', fillvalue) - call nfw_close(fname, ncid) - - where (vssh(:,:,1,1) .ne. fillvalue(1)) - vssh(:,:,1,1) = vssh(:,:,1,1) * scalefac(1) + addoffset(1) - end where - - !Read the monthly mean - allocate(vssh2(dlon,dlat,1,1)) - - print *, 'Start reading anom' - call nfw_open('mean_obs.nc', nf_nowrite, ncid) - print *, 'openning ID' - call nfw_inq_varid('mean_obs.nc', ncid, 'height', vSSH_ID) - print *, 'reading ID' - call nfw_get_var_real('mean_obs.nc', ncid, vSSH_ID, vssh2) - call nfw_get_att_real('mean_obs.nc', ncid, vSSH_ID, '_FillValue', fillvalue2) - print *, 'closing' - call nfw_close('mean_obs.nc', ncid) - print *, 'Finished reading anom' - - where (vssh(:,:,1,1) .ne. fillvalue(1) .and. vssh2(:,:,1,1) .ne. fillvalue2(1)) - vssh(:,:,1,1) = vssh(:,:,1,1) - vssh2(:,:,1,1) - elsewhere - vssh(:,:,1,1) = fillvalue(1) - end where - - ! read pre-estimated obs errors - call nfw_open('./obs_unc_SSH.nc', nf_nowrite, ncid) - call nfw_inq_varid('./obs_unc_SSH.nc', ncid, 'var_o', vSSH_ID) - call nfw_get_var_double('./obs_unc_SSH.nc', ncid, vSSH_ID, obs_unc) - call nfw_close('./obs_unc_SSH.nc', ncid) - - print *,'Nb obs mem' - nrobs=1 - wetsill = 200. ! Discarding data in shallow waters - do j = 1, dlat - do i = 1, dlon - call pivotp_micom(vlongitude(i), vlatitude(j), modlon, modlat, ipiv, jpiv, & - nx, ny, min_r, max_r,itw, jtw, itn, jtn, its, jts, ite, jte) -#ifdef MASK_LANDNEIGHBOUR - ipm1=max(ipiv-1,1) - ipp1=min(ipiv+1,nx) - jpm1=max(jpiv-1,1) - jpp1=min(jpiv+1,ny) - if (any(depths(ipm1:ipp1, jpm1:jpp1) < wetsill) ) cycle -#endif - if (depths(ipiv, jpiv) < wetsill ) cycle - if (vssh(i,j,1,1) .ne. fillvalue(1)) then - data(nrobs)%d = vssh(i,j,1,1) - data(nrobs)%ipiv = ipiv - data(nrobs)%jpiv = jpiv - !regular grid [-179.5 -> 179.5] & [89.5 -> -89.5] - data(nrobs)%lon = vlongitude(i) - data(nrobs)%lat = vlatitude(j) - data(nrobs)%a1 = 1 - data(nrobs)%a2 = 0 - data(nrobs)%a3 = 0 - data(nrobs)%a4 = 0 - data(nrobs)%ns = 0 - data(nrobs)%depth = 0 - data(nrobs)%date = 0 - data(nrobs)%id ='SSH' - data(nrobs)%orig_id =0 - data(nrobs)%i_orig_grid = -1 - data(nrobs)%j_orig_grid = -1 - data(nrobs)%h = 1 - data(nrobs)%status = .true. - data(nrobs)%var = max(0.0025, obs_unc(ipiv, jpiv)) - nrobs=nrobs+1 - endif - enddo ! dlat - enddo ! dlon - nrobs=nrobs-1 - print *,'Max,min obs',maxval(data(:)%d),minval(data(:)%d),maxval(data(:)%lon),minval(data(:)%lat) - print *,'Max,min age',maxval(data(:)%date),minval(data(:)%date) - ! print *,'Nb of obs',nrobs - ! print *,'Max,min lon',maxval(data(:)%lon),minval(data(:)%lon) - ! print *,'Max,min lat',maxval(data(:)%lat),minval(data(:)%lat) -end subroutine read_CLS_SSH -end module m_read_CLS_SSH diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST.F90 deleted file mode 100755 index 22db34fd..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST.F90 +++ /dev/null @@ -1,146 +0,0 @@ -module m_read_CLS_SST -! Reads CLS SST data after having read the grid in read_CLS_SST_grid - contains - - subroutine read_CLS_SST(fname,gr,data) - use mod_measurement -! use mod_dimensions - use mod_grid - use m_spherdist - use netcdf - use m_nf90_err - implicit none - - type (measurement), intent(inout) :: data(:) - type (grid), intent(inout) :: gr ! CLS measurement grid - character(len=80), intent(in) :: fname - -!dimension ids - integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID - -! Variable ids - integer :: vNbLatitudes_ID, vNbLongitudes_ID, vGrid0001_ID, vGrid0004_ID - -! Array dimensions - integer :: LatLon, NbLatitudes, NbLongitudes - -! Data arrays - real,allocatable :: sst(:,:), sst_var(:,:), lon(:),lat(:)!, latlon0(:), dlatlon(:) - -! utilitary - integer ncid, ijmax(2) - real undef,undef_lat, undef_lon, undef_var - integer i, j,k - logical valid - real, parameter :: eps = 0.01 ! test for undefined values - -! Open file -! filename='sst_topaz_19510.nc' - call nf90_err(NF90_OPEN(trim(fname),NF90_NOCLOBBER,ncid)) - -! Get dimension id in netcdf file ... - call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID)) - -! Get dimension length from id - call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes)) - print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon - -! State which variable you want here.. Available vars are shown when you do -! "ncdump -h " on the netcdf file. This is for SST and SDEV of SST - allocate(lon(NbLongitudes)) - allocate(lat(NbLatitudes)) -! allocate(latlon0(LatLon)) -! allocate(dlatlon(LatLon)) - allocate(sst_var(NbLatitudes,NbLongitudes)) - allocate(sst(NbLatitudes,NbLongitudes)) - -! Variable ids in netcdf file - call nf90_err(nf90_inq_varid(ncid,'NbLatitudes' ,vNbLatitudes_ID),'NbLatitudes') - call nf90_err(nf90_inq_varid(ncid,'NbLongitudes' ,vNbLongitudes_ID),'NbLongitudes') - call nf90_err(nf90_inq_varid(ncid,'Grid_0001' ,vGrid0001_ID),'Grid_0001') - call nf90_err(nf90_inq_varid(ncid,'Grid_0004' ,vGrid0004_ID),'Grid_0004') - -! Variable _FillValue attributes - call nf90_err(nf90_get_att(ncid,vNbLatitudes_ID , '_FillValue',undef_lat)) - call nf90_err(nf90_get_att(ncid,vNbLongitudes_ID ,'_FillValue',undef_lon)) - call nf90_err(nf90_get_att(ncid,vGrid0001_ID , '_FillValue',undef)) - call nf90_err(nf90_get_att(ncid,vGrid0004_ID , '_FillValue',undef_var)) - print*, 'Undefined values are ', undef_lat, undef_lon, undef, undef_var - gr%undef = undef - -! actual variable values (for dimensions of var -- see ncdump, or improve this program) -! NB: note that index dimensions are different between fortran and C internals. -! "ncdump" gives C internals. - print *,'test' - call nf90_err(nf90_get_var(ncid,vNbLongitudes_ID ,lon)) - print *,'Range Lon', minval(lon), maxval(lon) - call nf90_err(nf90_get_var(ncid,vNbLatitudes_ID ,lat)) - print *,'Range Lat', minval(lat), maxval(lat) - call nf90_err(nf90_get_var(ncid,vGrid0001_ID ,sst)) - print *,'Range SST', minval(sst), maxval(sst) - call nf90_err(nf90_get_var(ncid,vGrid0004_ID ,sst_var)) - print *,'Range Std. Dev.', minval(sst_var), maxval(sst_var) - -! print*, 'Latitudes' -! print '(12f8.2)',lat -! print*, 'Longitudes' -! print '(12f8.2)',lon - print '(4a10)','Lat','Lon','Temp[C]','Error[C]' -! print*,lat,lon,temp(i),err_temp(i),saln(i),err_saln(i) -! write(13,*)lat,lon,saln(i),err_saln(i),depth(i) -! write(14,*)lat,lon,temp(i),err_temp(i),depth(i) - ijmax = minloc(sst) - do i=ijmax(1)-5, ijmax(1)+5 - j = ijmax(2) - print '(4f10.3)', lat(i), lon(j), sst(i,j), sst_var(i,j) - enddo - - call nf90_err (nf90_close(ncid)) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Fill the data(:) vector - - do j=1,NbLongitudes ! gr%ny - do i=1,NbLatitudes ! gr%nx - k=(j-1)*gr%nx+i - - data(k)%id = 'SST' - data(k)%d = sst(i,j) - - data(k)%ipiv = i - data(k)%jpiv = j - - data(k)%lat=lat(i) - data(k)%lon=lon(j) - -!LB: Data support is assumed = a square grid cell -!support diameter in meters stored in %a1 (tricky, isn't it ?) - data(k)%a1 = spherdist(lon(j)-.5*gr%dx,lat(i)-.5*gr%dy, & - lon(j)+.5*gr%dx,lat(i)+.5*gr%dy) - data(k)%ns = 1 - - data(k)%var = sst_var(i,j) ! corrected: variance is provided - - data(k)%depth = 0.0 - - valid = (abs( (lon(j)-undef_lon) / undef_lon ) > eps & - .and. abs( (lat(i)-undef_lat) / undef_lat ) > eps & - .and. abs( (sst(i,j)-undef) / undef ) > eps & - .and. abs( (sst_var(i,j)-undef_var)/undef_var) > eps & - .and. sst_var(i,j)> 0 & - .and. sst_var(i,j)< 16 ) ! Sdev too high => perturbations too large - - data(k)%status = valid - - enddo - enddo - print*, 'Number of data read:', k, gridpoints(gr) - - deallocate(lat,lon,sst,sst_var) - -end subroutine read_CLS_SST -end module m_read_CLS_SST diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST_grid.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST_grid.F90 deleted file mode 100755 index ed52b3b2..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_SST_grid.F90 +++ /dev/null @@ -1,77 +0,0 @@ -module m_read_CLS_SST_grid - ! Reads the CLS SST NetCDF dimensions - -contains -subroutine read_CLS_SST_grid(filename,gr) - !use mod_dimensions - use mod_grid - use netcdf - use m_nf90_err - !use nfw_mod - implicit none - - character(len=80), intent(in) :: filename - type(grid), intent(out) :: gr - -!dimension ids - integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID - - -! Array dimensions - integer :: LatLon, NbLatitudes, NbLongitudes - real, allocatable :: latlon0(:), dlatlon(:) - -!variables ids - integer :: vLatLonMin_ID, vLatLonStep_ID - - integer :: ncid - - gr = default_grid - -! Open file -!filename='sst_topaz_19510.nc' - call nf90_err(NF90_OPEN(trim(filename),NF90_NOCLOBBER,ncid)) - !call nfw_open(trim(filename), nf_nowrite, ncid) - -! Get dimension id in netcdf file ... - call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID)) - call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID)) -! Get dimension length from id - call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes)) - call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes)) -! call nf90_err(nf90_Inquire_Dimension(ncid,GridDepth_ID,len=GridDepth)) - print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon - - allocate(latlon0(LatLon)) ! Grid origin coordinates - allocate(dlatlon(LatLon)) ! dx and dy - -! Variable ids in netcdf file - call nf90_err(nf90_inq_varid(ncid,'LatLonMin' ,vLatLonMin_ID),'LatLonMin') - call nf90_err(nf90_inq_varid(ncid,'LatLonStep' ,vLatLonStep_ID),'LatLonStep') - -! Variables in NetCDF file - call nf90_err(nf90_get_var(ncid,vLatLonMin_ID ,latlon0)) - print *, 'Grid Origin ', latlon0 - call nf90_err(nf90_get_var(ncid,vLatLonStep_ID ,dlatlon)) - print *, 'Grid Size ', dlatlon - - gr%nx=NbLatitudes - gr%ny=NbLongitudes - gr%x0= latlon0(1) - gr%y0= latlon0(2) -! gr%dx= 0.179 - gr%dx= dlatlon(1) - gr%dy= dlatlon(2) - gr%reg = .true. - gr%order = 2 - gr%ux = 'deg' - gr%uy = 'deg' - gr%set = .true. - - deallocate(latlon0,dlatlon) - - end subroutine read_CLS_SST_grid -end module m_read_CLS_SST_grid - diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA.F90 deleted file mode 100755 index 71f0263d..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA.F90 +++ /dev/null @@ -1,237 +0,0 @@ -module m_read_CLS_TSLA - - integer, parameter, private :: STRLEN = 512 - real(8), parameter, private :: RE_MULTIPLE = 0.7d0 - character(*), parameter, private :: RE_FNAME = "re_sla.nc" - -contains - - subroutine read_CLS_TSLA(filename, gr, data) - use mod_measurement - use mod_grid - use nfw_mod - implicit none - - character(*), intent(in) :: filename - type(grid), intent(inout) :: gr ! CLS measurement grid - type(measurement), intent(inout) :: data(:) - - integer :: data_ID, track_ID, cycl_ID - integer :: vNbpoint_ID, vLongitude_ID, vLatitude_ID, vBegindate_ID, vSLA_ID - - ! array dimensions - integer :: nb, ntracks, ncycles - - ! data arrays - real(8), allocatable :: vsla(:,:), vlon(:), vlat(:), vbegindate(:,:) - integer, allocatable :: vnbpoint(:) - logical, allocatable :: isgood(:,:) - - integer :: ncid - real(8), dimension(1) :: undef_sla, undef_lat, undef_lon, undef_begindate - real(8) :: varsat - integer, dimension(1) :: undef_nbpoint - integer :: i, j, k, nobs, obsid, sid, age - real(8), parameter :: EPS = 0.01 ! test for undefined values - character(STRLEN) :: ftemplate - character(STRLEN) :: fname - character(STRLEN) :: fpath - logical :: ex - - print *, 'read_CLS_TSLA():' - - fpath='./' - read(filename,'(i7)') age - nobs = 0 - do sid = 1, 7 ! loop over satellite ID - select case(sid) - case(1) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_en*.nc' - varsat = 0.0009 ! 3 cm for ENVISAT - print *, ' ENVISSAT:' - case(2) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_j1*.nc' - varsat = 0.0009 ! 3 cm for ENVISAT Jason1 - print *, ' Jason1:' - case(3) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_j2*.nc' - varsat = 0.0009 ! 3 cm for ENVISAT Jason2 - print *, ' Jason2:' - case(4) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_e1*.nc' - varsat = 0.0075 ! 8.5 cm for e1 - print *, ' ERS1:' - case(5) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_e2*.nc' - varsat = 0.0075 ! 8.5 cm for e2 - print *, ' ERS2:' - case(6) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_tp*.nc' - varsat = 0.0030 ! 5.5 cm for TOPEX - print *, ' TOPEX:' - case(7) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_g2*.nc' - varsat = 0.0030 ! GEOSAT - print *, ' GEOSAT2:' - end select - - call fname_fromtemplate(ftemplate, fname) - inquire(file = trim(fname), exist = ex) - if (.not. ex) then - cycle - end if - - ! Reading the observation file of satellite - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_dimid(fname, ncid, 'Data', data_ID) - call nfw_inq_dimid(fname, ncid, 'Tracks', track_ID) - call nfw_inq_dimid(fname, ncid, 'Cycles', cycl_ID) - - call nfw_inq_dimlen(fname, ncid, data_ID, nb) - call nfw_inq_dimlen(fname, ncid, track_ID, ntracks) - call nfw_inq_dimlen(fname, ncid, cycl_ID, ncycles) - print '(1x, a, 3i8)', ' dimensions (# obs, # tracks, # cycles):', nb, ntracks, ncycles - - allocate(vlon(nb), vlat(nb), vsla(ncycles, nb)) - allocate(vnbpoint(ntracks), vbegindate(ncycles, ntracks)) - allocate(isgood(ncycles, ntracks)) - - ! Variable ids in netcdf file - call nfw_inq_varid(fname, ncid, 'Latitudes', vLatitude_ID) - call nfw_inq_varid(fname, ncid,'Longitudes', vLongitude_ID) - call nfw_inq_varid(fname, ncid,'BeginDates', vBegindate_ID) - call nfw_inq_varid(fname, ncid,'NbPoints', vNbpoint_ID) - call nfw_inq_varid(fname, ncid,'SLA', vSLA_ID) - - ! Variable _FillValue attributes - call nfw_get_att_double(fname, ncid, vLatitude_ID , '_FillValue', undef_lat(1)) - call nfw_get_att_double(fname, ncid, vLongitude_ID , '_FillValue', undef_lon(1)) - call nfw_get_att_double(fname, ncid, vSLA_ID, '_FillValue', undef_sla(1)) - call nfw_get_att_int(fname, ncid, vNbpoint_ID, '_FillValue', undef_nbpoint(1)) - call nfw_get_att_double(fname, ncid,vBegindate_ID, '_FillValue', undef_begindate(1)) - gr % undef = undef_sla(1) - - call nfw_get_var_double(fname, ncid, vLongitude_ID, vlon) - call nfw_get_var_double(fname, ncid, vLatitude_ID, vlat) - call nfw_get_var_double(fname, ncid, vSLA_ID, vsla) - !lon = ang180(lon) - vlon = vlon * 1.e-06 - vlat = vlat * 1.e-06 - print '(1x, a, 2f10.2)', ' range Lon = ', minval(vlon), maxval(vlon) - print '(1x, a, 2f10.2)', ' range Lat = ', minval(vlat), maxval(vlat) - print '(1x, a, 2f10.2)', ' range SLA = ', minval(vsla), maxval(vsla) - - call nfw_get_var_int(fname, ncid, vNbpoint_ID, vnbpoint) - call nfw_get_var_double(fname, ncid, vBegindate_ID, vbegindate) - print '(1x, a, 2i8)', ' range nbpoints = ', minval(vnbpoint), maxval(vnbpoint) - print *, ' age = ', age - isgood = .false. - where (vbegindate /= undef_begindate(1)) - vbegindate = age - floor(vbegindate) - 1 - isgood = .true. - end where - print '(3x,a,2G10.3)',' range begin_date (days from assim) = ', & - minval(pack(vbegindate, isgood)), maxval(pack(vbegindate, isgood)) - call nfw_close(fname, ncid) - - ! Here we set the reference the date with respect to the assimilation - ! date (0=today, 6=is 6 day old). - ! Fanf: We assume that the data from the same pass have the same - ! date=begindate(passnb). - ! We also assume that envisat, J1 and J2 have similar accuracy, and - ! thus use data%var to store the age of the data. Only data that are - ! younger than 6 days are retained such that we do not assimilate the - ! same obs twice. - do k = 1, ncycles - obsid = 0 - do i = 1, ntracks - do j = 1, vnbpoint(i) - obsid = obsid + 1 - ! only consider data above -30 of lat - if (vlat(obsid) <= -30.0 .or.& - vbegindate(k, i) >= 7 .or. vbegindate(k, i) <= -1 .or.& - vlon(obsid) == undef_lon(1) .or.& - vlat(obsid) == undef_lat(1) .or.& - vsla(k, obsid) == undef_sla(1)) then - cycle - end if - nobs = nobs + 1 - data(nobs) % id = 'TSLA' - data(nobs) % d = vsla(k, obsid) * 0.001 ! conversion to meters - data(nobs) % ipiv = -1 ! to be filled - data(nobs) % jpiv = -1 - data(nobs) % lat = vlat(obsid) - data(nobs) % lon = ang180(vlon(obsid)) - data(nobs) % a1 = -1.0e10 ! to be filled - data(nobs) % a2 = -1.0e10 - data(nobs) % a3 = -1.0e10 - data(nobs) % a4 = -1.0e10 - data(nobs) % ns = 0 - data(nobs) % var = varsat - data(nobs) % date = int(vbegindate(k, i)) - data(nobs) % depth = 0.0 - data(nobs) % status = .true. - enddo ! Vnbpoint - enddo ! track - enddo ! cycle - print*, ' # of obs read so far = ', nobs - deallocate(vlat, vlon, vsla, vnbpoint, vbegindate, isgood) - end do ! satellite id - gr % nx = nobs - end subroutine read_CLS_TSLA - - - subroutine set_re_TSLA(nrobs, obs, nx, ny, modlon, modlat) - use mod_measurement - use nfw_mod - - integer, intent(in) :: nrobs - type(measurement), dimension(nrobs), intent(inout) :: obs - integer, intent(in) :: nx, ny - real, dimension(nx, ny), intent(in) :: modlon, modlat - - integer :: ncid, reid - real, dimension(nx, ny) :: re - real :: reo - integer :: o - - print *, ' reading representation error from "', trim(RE_FNAME), '"' - - call nfw_open(RE_FNAME, nf_nowrite, ncid) - call nfw_inq_varid(RE_FNAME, ncid, 're_sla', reid) - call nfw_get_var_double(RE_FNAME, ncid, reid, re) - call nfw_close(RE_FNAME, ncid) - - do o = 1, nrobs - reo = re(obs(o) % ipiv, obs(o) % jpiv) - if (reo < 0 .or. reo > 1.0d5) then - cycle - end if - ! PS 1.4.2010 Increased the multiple for representation error from - ! 0.3 to 0.5 - it seems that with 0.3 it wants to do more in the Gulf - ! Stream region than the model can sustain. - ! PS June 2010 - further increased the multiple to 0.7. - obs(o) % var = obs(o) % var + RE_MULTIPLE * reo - end do - end subroutine set_re_TSLA - - - subroutine fname_fromtemplate(ftemplate, fname) - character(*), intent(in) :: ftemplate - character(*), intent(inout) :: fname - - character(STRLEN) :: command ! (there may be a limit of 80 on some systems) - integer :: ios - - command = 'ls '//trim(ftemplate)//' 2> /dev/null > tsla_files.txt' - call system(trim(command)); - - open(10, file = 'tsla_files.txt') - read(10, fmt = '(a)', iostat = ios) fname - close(10) - if (ios /= 0) then - fname = "" - end if - end subroutine fname_fromtemplate - -end module m_read_CLS_TSLA diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA_grid.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA_grid.F90 deleted file mode 100755 index 1d125909..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_TSLA_grid.F90 +++ /dev/null @@ -1,99 +0,0 @@ -module m_read_CLS_TSLA_grid - ! Reads the CLS SST NetCDF dimensions - - integer, parameter, private :: STRLEN = 512 - -contains - subroutine read_CLS_TSLA_grid(filename,gr) - !use mod_dimensions - use mod_grid - use netcdf - use nfw_mod - implicit none - - character(len=80), intent(in) :: filename - type(grid), intent(out) :: gr - character(len=80) :: fname - logical :: ex - !dimension ids - integer :: data_ID,cycl_ID - - ! Array dimensions - integer :: nb,cycl - - integer :: ncid,fcount - character(STRLEN) :: Fpath - character(STRLEN) :: ftemplate - - print *, 'read_CLS_TSLA_grid():' - - gr = default_grid - gr%nx=0 - Fpath='./' - ! Open file - do fcount=1,7 !2 satellite Envissat,J2 - select case(fcount) - case(1) - ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_en*.nc' - case(2) - ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j1*.nc' - case(3) - ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j2*.nc' - case(4) - ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e1*.nc' - case(5) - ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e2*.nc' - case(6) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_tp*.nc' - case(7) - ftemplate = trim(fpath)//'sla_'//trim(filename)//'_g2*.nc' - end select - call fname_fromtemplate(ftemplate, fname) - inquire(file=trim(fname),exist=ex) - if(ex) then - call nfw_open(fname, nf_nowrite, ncid) - print *, ' found "', trim(fname), '"...' - - ! Get dimension id in netcdf file ... - call nfw_inq_dimid(fname, ncid, 'Data', data_ID) - call nfw_inq_dimid(fname, ncid, 'Cycles', cycl_ID) - ! Get dimension length from id - call nfw_inq_dimlen(fname, ncid, data_ID, nb) - call nfw_inq_dimlen(fname, ncid, cycl_ID, cycl) - call nfw_close(fname, ncid) - - gr%nx=gr%nx+nb*cycl - gr%ny=1 - gr%x0=0 - gr%y0=0 - gr%dx=0.1 - gr%dy=0.1 - gr%reg = .false. - gr%order = 1 - gr%ux = 'm' - gr%uy = 'm' - gr%set = .true. - endif - enddo - end subroutine read_CLS_TSLA_grid - - - subroutine fname_fromtemplate(ftemplate, fname) - character(*), intent(in) :: ftemplate - character(*), intent(inout) :: fname - - character(STRLEN) :: command ! (there may be a limit of 80 on some systems) - integer :: ios - - command = 'ls '//trim(ftemplate)//' 2> /dev/null > tsla_files.txt' - call system(trim(command)); - - open(10, file = 'tsla_files.txt') - read(10, fmt = '(a)', iostat = ios) fname - close(10) - if (ios /= 0) then - fname = "" - end if - end subroutine fname_fromtemplate - -end module m_read_CLS_TSLA_grid diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_data.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_data.F90 deleted file mode 100755 index 1af88b4f..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_data.F90 +++ /dev/null @@ -1,142 +0,0 @@ - module m_read_CLS_data -! Reads SLA and SST data from CLS, Toulouse, France -! Files are given as .asc (lat,lon,data) -! The data points are surface data and therefore the data(k)%depths=0 -! This subroutine also prepares the gridd which the data -! Is provided on. - -contains - - subroutine read_CLS_data(fname,obstype,dformat,gr,form,data,factor,var) - use mod_measurement - use mod_grid - use m_spherdist - implicit none - - type (measurement), intent(inout) :: data(:) - type (grid), intent(in) :: gr ! CLS measurement grid - real, intent(in) :: factor, var - - character(len=80), intent(in) :: fname,dformat - character(len=3), intent(in)::form - character(len=*), intent(in)::obstype - integer :: k, telli, tellj, nrdat, dum - logical :: ex, found, fleeting - real :: lon, lat -#ifdef ANOMALY - character(len=80) :: fname_anom - real :: lon_anom, lat_anom, dum_anom - fname_anom='Average_Reynolds-1981-2007.txt' -#endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read observation file - if (trim(form) == '0') stop 'read_CLS_data: illegal format ' - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'read_CLS_data: file ', fname, ' not found.' - stop - end if -#ifdef ANOMALY - inquire (file=fname_anom, exist=ex) - if (.not. ex) then - print *, 'read_CLS_data: file ', fname_anom, ' not found.' - stop - end if -#endif - -!std = 0.0; lat = 0.0; lon = 0.0 - -!!! Find out if data column is type integer or not - - found = .false. - found = ((scan(dformat,'i') > 0) .or. (scan(dformat,'I') > 0)) - fleeting = .not. found - - open (10, file=fname, form='formatted', status='old') -#ifdef ANOMALY - open (20, file=fname_anom, form='formatted', status='old') -#endif - - telli=1 - tellj=1 - - do k = 1, gridpoints(gr) - data(k)%id = obstype - - if (fleeting) then ! Data column floating point - read (10,dformat,end=999,err=999) lat, lon, data(k)%d -#ifdef ANOMALY - read (20,dformat,end=999,err=999) lat_anom, lon_anom, dum_anom - if (abs(lat_anom-lat)<0.001 .and. abs(lon_anom-lon)<0.001 .and. dum_anom<100) then - data(k)%d=data(k)%d-dum_anom - elseif (dum_anom<100) then - print *,'Something is wrong we have the lon lat mistmatch' - print *,lat_anom,lat,lon_anom,lon,dum_anom, data(k)%d - end if -#endif - else ! Data column integer valued - read (10,dformat,end=999,err=999) lat, lon, dum - data(k)%d = real(dum) - end if -! print*,'lat',lat,'lon', lon,'data',data(k)%d - -!NBNBN Avoid sla data in region 3S to 3N (due to strange Ifremer mean ssh in this region): - -! if (trim(data(k)%id) == 'ssh' .or. trim(data(k)%id) == 'SSH') then -! if ((lat.ge.-3.0).and.(lat.le.3.0)) then -! data(k)%d = 999.9 -! endif -! endif - - if (.not. undefined(data(k)%d,gr)) then - data(k)%d = data(k)%d*factor ! Convert to proper units - end if - - data(k)%jpiv = telli - data(k)%ipiv = tellj -! iloop(k) = telli -! jloop(k) = tellj - - - telli = telli + 1 - - if (telli > gr%ny) then - tellj=tellj+1 - telli = 1 - endif - - data(k)%lon=lon - data(k)%lat=lat - -!LB: Data support is assumed = a square grid cell -!support diameter stored in %a1 (tricky, isn't it ?) - data(k)%a1 = spherdist(lon-.5*gr%dx,lat-.5*gr%dy,lon+.5*gr%dx,lat+.5*gr%dy) - data(k)%ns = 1 - data(k)%status = .not. undefined(data(k)%d,gr) ! active data - - if (trim(obstype) == 'SST') then - data(k) % status = data(k) % status .and.& - abs(data(k) % d + 1.8d0) > 1.0d-6 - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! In the case of SSH data the var parameter is given for each data point !!!! -! - if (trim(data(k)%id) == 'ssh' .or. trim(data(k)%id) == 'SSH') then - data(k)%var = var !!!NBNBNB + std**2 - else - data(k)%var = var - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - data(k)%depth = 0.0 - enddo ! k = 1, gridpoints(gr) -999 continue - nrdat =k-1 - print*, 'Number of data read:', nrdat - close(10) - close(20) - -end subroutine read_CLS_data - -end module m_read_CLS_data diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_header.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_header.F90 deleted file mode 100755 index 43c86428..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_CLS_header.F90 +++ /dev/null @@ -1,66 +0,0 @@ - module m_read_CLS_header -! Reads the CLS header stored as sla.hdr or sst.hdr - -contains - subroutine read_CLS_header(fnamehdr,gr,dataformat,form,factor,var) - use mod_grid - implicit none - - type (grid), intent(out) :: gr - - character(len=80),intent(in) :: fnamehdr - character(len=80),intent(out) :: dataformat - character(len=80) :: title - character(len=3), intent (out)::form - integer :: lastchar - real, intent(out) :: factor, var - - logical :: ex - - gr = default_grid - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read .hdr file information - inquire (file=fnamehdr,exist=ex) - if (ex) then - open (10,file=fnamehdr) - read (10,'(a)') title - read (10,'(a3)') form - read (10,'(a80)') dataformat - read (10,*) gr%undef, factor, var - lastchar = scan(dataformat,')') - dataformat(lastchar+1:80) = ' ' - print '(2a)','title : ', trim(title) - print '(2a)','Form : ', form - print '(2a)','data format: ', trim(dataformat) - print '(a,3e14.3)','undef factor var: ', gr%undef,factor,var - -!Reads the observation gridd - if (form == 'reg') then - read (10,*) gr%nx,gr%ny,gr%x0,gr%y0,gr%dx,gr%dy - gr%reg = .true. - gr%order = 2 - gr%ux = 'deg' - gr%uy = 'deg' - elseif (form == 'irr') then - read (10,*) gr%nx - gr%reg = .false. - gr%order = 1 - else - stop 'readhdr: Header error, format should be reg or irr' - end if - gr%set = .true. - close (10) - - else - form = '0' ! File not found. - gr%set = .false. - print*, title - stop 'read_CLS_header: no data header' - end if - - print *,' No of gridpoints: ', gridpoints(gr) -! print '(a,a3,a,f8.4)','Error variance of dataset ',obstype, ' is', var -end subroutine read_CLS_header -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module m_read_CLS_header diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_EN4_profile.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_EN4_profile.F90 deleted file mode 100755 index 65b3a04f..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_EN4_profile.F90 +++ /dev/null @@ -1,921 +0,0 @@ -! File: m_read_EN4_profile.F90 -! -! Created: 17 July 2015 -! -! Author: Yiguo WANG (YW) -! NERSC -! -! Purpose: Read profile data from NetCDF files from EN4 into NorCPM -! system. -! -! Description: Data file(s) are defined by the string in the 4th line of -! "infile.data". It should have the following format: -! -! EN4 -! SAL | TEM -! -! -! -! After that: -! 1. all profiles are read into two arrays, -! deph(1 : nlev, 1 : nprof) and v(1 : nlev, 1 : nprof), where -! nprof is the total number of profiles in all files, and -! nlev is the maximum number of horizontal levels for all -! profiles; -! 2. bad data with qc flags other than '1' is discarded; -! 3. dry or outside locations are discarded -! 4. if there close profiles (in the same grid cell), the best -! one (with most data or the most recent) is retained -! -! - -module m_read_EN4_profile - implicit none - - integer, parameter, private :: STRLEN = 512 - integer, parameter, private :: kdm = 42 - integer, parameter, private :: kdm1 = 42 - - real, parameter, private :: DENS_DIFF_MIN = -0.02 - logical, parameter, private :: DISCARD_CLOSE = .false. - -#ifdef ANOMALY - ! anomaly - real, parameter, private :: TEM_MIN = -6.0 - real, parameter, private :: TEM_MAX = 6.0 - real, parameter, private :: SAL_MIN = -3.0 - real, parameter, private :: SAL_MAX = 3.0 -#else - ! full field - real, parameter, private :: TEM_MIN = -2.5 - real, parameter, private :: TEM_MAX = 35.0 - real, parameter, private :: SAL_MIN = 1.0 - real, parameter, private :: SAL_MAX = 50.0 -#endif - - public read_EN4_profile - - private data_inquire - private data_readfile - private potential_density - private get_pivot - private data_variance - private data_obsunc -contains - - subroutine read_EN4_profile(fnames, obstype, variance, nx, ny, data, nrobs) - use mod_measurement - use m_oldtonew - use m_confmap - use m_bilincoeff - use m_pivotp - use nfw_mod - use ieee_arithmetic - use m_get_micom_fld - - character(*), intent(in) :: fnames - character(*), intent(in) :: obstype - real(8), intent(in) :: variance - integer, intent(in) :: nx, ny - integer, intent(out) :: nrobs - type(measurement), allocatable, intent(out) :: data(:) - - character(STRLEN) :: fname - integer :: nfile, nprof, nlev - - real(8), allocatable :: juld(:) - real(8), allocatable :: lat(:), lon(:) - real(8), allocatable :: deph(:,:) - real(8), allocatable :: temp(:,:), salt(:, :) - - character, allocatable :: pos_qc(:) - character, allocatable :: temp_qc(:,:), salt_qc(:, :) - character, allocatable :: prof_temp_qc(:),prof_saln_qc(:) - - integer, allocatable :: ipiv(:), jpiv(:) - - real(8), dimension(nx, ny) :: modlat, modlon - real(8), dimension(nx, ny) :: depths, mxd1, mxd2, fice - - real(8), dimension(nx, ny, kdm1) :: obs_unc - real(8), dimension(2, kdm1) :: d3z - - real(8), dimension(360, 173, kdm) :: obs_mean - real(8), dimension(360) :: dlon - real(8), dimension(173) :: dlat - real(8), dimension(kdm) :: ddepth - real(8), allocatable, dimension(:) :: splinex, spliney, splined - real(8), allocatable, dimension(:) :: splinexe, splineye - integer :: lon_int, lat_int - - integer :: f, l, p, np, k, ll - integer :: ipp1,ipm1,jpp1,jpm1 - integer, allocatable :: mask(:) - integer, allocatable :: mask2(:, :) - integer, allocatable :: fid(:); - integer, allocatable :: profid(:) - integer, allocatable :: done(:) - real(8) :: zmax, Q, Qbest, rho, rho_prev, rho_inc - integer :: best - integer :: p1 - - integer ngood, ndata - real(8) :: latnew, lonnew - - print *, 'BEGIN read_EN4_profile()' - - call data_inquire(fnames, nfile, nprof, nlev) - print *, ' overall: nprof =', nprof, ', nlev =', nlev - - allocate(juld(nprof)) - allocate(lat(nprof)) - allocate(lon(nprof)) - allocate(temp(nlev, nprof)) - allocate(salt(nlev, nprof)) - allocate(deph(nlev, nprof)) - - allocate(pos_qc(nprof)) - allocate(temp_qc(nlev, nprof)) - allocate(salt_qc(nlev, nprof)) - allocate(prof_temp_qc(nprof)) - allocate(prof_saln_qc(nprof)) - - allocate(fid(nprof)) - allocate(profid(nprof)) - - ! read pre-estimated obs uncertainties - ! - fname = './obs_unc_'//trim(obstype)//'.nc' - call data_obsunc(trim(fname), trim(obstype), d3z, obs_unc) - - ! read data - ! - p = 1 - do f = 1, nfile - call data_readfile(f, np, juld(p : nprof),& - lat(p : nprof), lon(p : nprof), pos_qc(p : nprof), & - temp(1 : nlev, p : nprof), temp_qc(1 : nlev, p : nprof), & - salt(1 : nlev, p : nprof), salt_qc(1 : nlev, p : nprof), & - deph(1 : nlev, p : nprof), prof_temp_qc(p : nprof), & - prof_saln_qc(p : nprof)) - fid(p : p + np - 1) = f - do l = 1, np - profid(p + l - 1) = l - end do - p = p + np - end do - - allocate(mask(nprof)) - mask(:) = 1 - allocate(mask2(nlev, nprof)) - mask2(:, :) = 1 - -#ifdef ANOMALY - ! read climatology - fname = 'mean_obs.nc' - call data_obsmean(trim(fname), trim(obstype), ddepth, dlon, dlat, obs_mean) - - do p = 1, nprof - if ((lat(p) .lt. minval(dlat)) .or. (lat(p) .gt. maxval(dlat))) then - mask(p) = 0 - mask2(:, p) = 0 - cycle - end if - - ! identify coordinate in obs_mean - lon_int = modulo(nint(lon(p)), 360) - if (lon_int .eq. 0) lon_int = 360 - lat_int = nint(lat(p)) + 84 - - ! find available depth for obs_mean - f = count(obs_mean(lon_int, lat_int, :) .gt. -10000.) - if (f .lt. 2) then - mask(p) = 0 - mask2(:, p) = 0 - cycle - end if - - allocate(splinex(f), spliney(f),splined(f)) - l = 0 - do k = 1, kdm - if (obs_mean(lon_int, lat_int, k) .gt. -10000.) then - l = l + 1 - splinex(l) = ddepth(k) - spliney(l) = obs_mean(lon_int, lat_int, k) - end if - end do - if (l .ne. f) print *, 'Error in spline: l /= f' - call spline_pchip_set(f, splinex, spliney, splined) - - ! find available depths in obs - f = count(deph(:, p) .lt. 10000.) - if (f .lt. 1) then - mask(p) = 0 - mask2(:, p) = 0 - deallocate(splinex, spliney, splined) - cycle - end if - - allocate(splinexe(f), splineye(f)) - ll = 0 - do k = 1, nlev - if (deph(k, p) .lt. 10000.) then - ll = ll + 1 - splinexe(ll) = deph(k, p) - end if - end do - if (ll .ne. f) print *, 'Error in spline: ll /= f' - call spline_pchip_val(l, splinex, spliney, splined, & - ll, splinexe, splineye) - - ! calcule anomaly - ll = 0 - if (trim(obstype) == 'SAL') then - do k = 1, nlev - if (deph(k, p) .lt. maxval(splinex)) then - ll = ll + 1 - salt(k, p) = salt(k, p) - splineye(ll) - else if (deph(k, p) .lt. 10000.) then - ll = ll + 1 - mask2(k, p) = 0 - else - mask2(k, p) = 0 - end if - end do - else if (trim(obstype) == 'TEM') then - do k = 1, nlev - if (deph(k, p) .lt. maxval(splinex)) then - ll = ll + 1 - temp(k, p) = temp(k, p) - splineye(ll) - else if (deph(k, p) .lt. 10000.) then - ll = ll + 1 - mask2(k, p) = 0 - else - mask2(k, p) = 0 - end if - end do - else - print *, 'ERROR: Anomaly: should be or ...' - stop - end if - deallocate(splinex, spliney, splined, splinexe, splineye) - end do -#endif - - ! mask <- pos_qc - ! - where (pos_qc .ne. '1') mask = 0 - where ((lat .lt. -90) .or. (lat .gt. 89)) mask = 0 - where ((lon .lt. -180) .or. (lon .gt. 180)) mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after examining POS_QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! ipiv, jpiv - ! - allocate(ipiv(nprof)) - allocate(jpiv(nprof)) - ipiv(:) = -999 - jpiv(:) = -999 - call get_pivot(nx, ny, nprof, lon, lat, ipiv, jpiv, depths, modlon, modlat) - where (ipiv < 1 .or. jpiv < 1 .or. ipiv > nx - 1 .or. jpiv > ny - 1) mask = 0 - - do p = 1, nprof - if (ipiv(p) < 1 .or. jpiv(p) < 1) then - print *, 'negatif values for ipiv, jpiv' - print *, 'ipiv=', ipiv - print *, 'jpiv=', jpiv - mask = 0 - end if - end do - - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after calculating pivot points:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Check land grid - ! - do p = 1, nprof -#ifdef MASK_LANDNEIGHBOUR - ipm1=max(ipiv(p)-1,1) - ipp1=min(ipiv(p)+1,nx) - jpm1=max(jpiv(p)-1,1) - jpp1=min(jpiv(p)+1,ny) - if (any(depths(ipm1:ipp1, jpm1:jpp1) < 60) ) mask(p) = 0 -#endif - if (depths(ipiv(p), jpiv(p)) < 60) mask(p) = 0 - end do - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after examinating model land points:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Check for the observation being wet - ! - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - if (deph(l, p) > depths(ipiv(p), jpiv(p)) .or.& - deph(l, p) > depths(ipiv(p) + 1, jpiv(p)) .or.& - deph(l, p) > depths(ipiv(p), jpiv(p) + 1) .or.& - deph(l, p) > depths(ipiv(p) + 1, jpiv(p) + 1)) then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - print *, ' after examining for wet cells:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Check for the observation above mixed layer - ! - fname = 'forecast001' - call get_micom_fld_new(trim(fname), mxd1, 'dp', 1, 1, nx, ny) - call get_micom_fld_new(trim(fname), mxd2, 'dp', 2, 1, nx, ny) - mxd1 = (mxd1 + mxd2) / 98060. ! Unit: meter - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - if (deph(l, p) < mxd1(ipiv(p), jpiv(p))) then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - print *, ' after examining for obs above the mixed layer:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! - ! Now examine 3D quality flags; set the mask for a profile to 0 if there - ! are no good samples in this profile - ! - - ! _qc - ! - if (trim(obstype) == 'SAL') then - where (prof_saln_qc .ne. '1') mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - - do p = 1, nprof - do l = 1, nlev - if (salt_qc(l, p) /= '1') then - mask2(l, p) = 0 - end if - if ((salt(l, p) .lt. SAL_MIN) .or. (salt(l, p) .gt. SAL_MAX)) then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - else if (trim(obstype) == 'TEM') then - where (prof_temp_qc .ne. '1') mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - - do p = 1, nprof - do l = 1, nlev - if (temp_qc(l, p) /= '1') then - mask2(l, p) = 0 - end if - if ((temp(l, p) .lt. TEM_MIN) .or. (temp(l, p) .gt. TEM_MAX)) then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - end if - print *, ' after examining prof__QC and _QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Finally, discard redundant observations - ! This is a O(n^2) search, which can become a bit long when the number of - ! examined profiles becomes really large (say, 10^4) - ! - if (DISCARD_CLOSE) then - allocate(done(nprof)) - done = 0 - do p = 1, nprof - if (mask(p) == 0 .or. done(p) == 1) then - cycle - end if - np = 1 - profid(np) = p - do p1 = p + 1, nprof - if (ipiv(p1) == ipiv(p) .and. jpiv(p1) == jpiv(p)) then - np = np + 1 - profid(np) = p1 - done(p1) = 1 - end if - end do - if (np > 1) then - ! for each of close profiles find the depth range, number of points - ! and the age - Qbest = 0.0 - do p1 = 1, np - zmax = 0.0 - ndata = 0 - do l = 1, nlev - if (mask2(l, profid(p1)) == 1) then - ndata = ndata + 1 - if (deph(l, profid(p1)) > zmax) then - zmax = deph(l, profid(p1)) - end if - end if - end do - Q = min(zmax, 400.0) / 400.0 + min(ndata, 10) / 10 - if (Q > Qbest) then - best = p1 - end if - end do - do p1 = 1, np - if (p1 == best) then - cycle - end if - mask(profid(p1)) = 0 - mask2(:, profid(p1)) = 0 - end do - end if - end do - deallocate(done) - print *, ' after discarding close profiles:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - end if ! DISCARD_CLOSE - - ! Read sea ice clim from model - fname = 'mean_mod' - call get_micom_fld_new(trim(fname), fice, 'fice', 0, 1, nx, ny) - - ngood = count(mask2 == 1) - nrobs = ngood - allocate(data(ngood)) - ndata = 0 - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - - ndata = ndata + 1 - - if (ndata > ngood) then - print *, 'ERROR: read_EN4_profile(): programming error' - print *, ' p =', p, ', l =', l - print *, ' # data =', ndata, ', ngood =', ngood - stop - end if - - ! PS: I guess we should not bother about the cost of the - ! comparisons below. - ! - if (trim(obstype) == 'SAL') then - data(ndata) % d = salt(l, p) - else if (trim(obstype) == 'TEM') then - data(ndata) % d = temp(l, p) -! if (ipiv(p) == 18 .and. jpiv(p) == 137 .and. temp(l, p) < -5) print *, p - else - print *, 'ERROR: read_EN4_profile(): should be or ...' - stop - end if - data(ndata) % id = obstype - data(ndata) % lon = lon(p) - data(ndata) % lat = lat(p) - data(ndata) % depth = max(0.0, deph(l, p)) - if (variance > 0) then - data(ndata) % var = variance - else - call data_variance(trim(obstype), data(ndata) % depth, data(ndata) % var) - end if - do k = 1,kdm1 - if (data(ndata) % depth >= d3z(1,k) .and. data(ndata) % depth < d3z(2,k)) then - data(ndata) % var = max(data(ndata) % var, obs_unc(ipiv(p), jpiv(p), k)) - exit - end if - end do - if (fice(ipiv(p), jpiv(p)) > 15.0) data(ndata) % var = 10.0 * data(ndata) % var - data(ndata) % ipiv = ipiv(p) - data(ndata) % jpiv = jpiv(p) - data(ndata) % ns = 0 ! for a point (not gridded) measurement - data(ndata) % date = 0 ! assimilate synchronously - - data(ndata) % a1 = 1 - data(ndata) % a2 = 0 - data(ndata) % a3 = 0 - data(ndata) % a4 = 0 -! call bilincoeff1(modlon, modlat, nx, ny, lon(p), lat(p), ipiv(p),& -! jpiv(p), data(ndata) % a1, data(ndata) % a2, data(ndata) % a3,& -! data(ndata) % a4) - - data(ndata) % status = .true. ! (active) - data(ndata) % i_orig_grid = p - data(ndata) % j_orig_grid = l - data(ndata) % orig_id = 0 - data(ndata) % h = 0 - end do - end do - - if (ndata /= ngood) then - print *, 'ERROR: read_EN4_profile(): programming error' - print *, ' ndata =', ndata, ', ngood =', ngood - stop - end if - - deallocate(juld) - deallocate(lat) - deallocate(lon) - deallocate(pos_qc) - deallocate(fid) - deallocate(profid) - deallocate(temp) - deallocate(salt) - deallocate(temp_qc) - deallocate(salt_qc) - deallocate(deph) - deallocate(prof_temp_qc) - deallocate(prof_saln_qc) - deallocate(mask) - deallocate(mask2) - deallocate(ipiv) - deallocate(jpiv) - - print *, 'END read_EN4_profile()' - - end subroutine read_EN4_profile - - - subroutine data_inquire(fnames, nfile, nprof, nlev) - use nfw_mod - - character(*), intent(in) :: fnames - integer, intent(inout) :: nfile, nprof, nlev - - character(STRLEN) :: command ! (there may be a limit of 80 on some systems) - character(STRLEN) :: fname - integer :: ios - integer :: ncid - integer :: id - - integer :: nprof_this, nlev_this - - nfile = 0 - nprof = 0 - nlev = 0 - - command = 'ls '//trim(fnames)//' > infiles.txt' - call system(command); - - nfile = 0 - open(10, file = 'infiles.txt') - do while (.true.) - read(10, fmt = '(a)', iostat = ios) fname - if (ios /= 0) then - exit - end if - - nfile = nfile + 1 - print *, ' file #', nfile, ' = "', trim(fname), '"' - - call nfw_open(fname, nf_nowrite, ncid) - - ! nprof - ! - call nfw_inq_dimid(fname, ncid, 'N_PROF', id) - call nfw_inq_dimlen(fname, ncid, id, nprof_this) - print *, ' nprof = ', nprof_this - - ! nlev - ! - call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id) - call nfw_inq_dimlen(fname, ncid, id, nlev_this) - print *, ' nlev = ', nlev_this - - nprof = nprof + nprof_this - if (nlev_this > nlev) then - nlev = nlev_this - end if - - call nfw_close(fname, ncid) - end do - close(10) - end subroutine data_inquire - - - subroutine data_readfile(fid, nprof, juld_all, & - lat_all, lon_all, pos_qc_all, temp_all, temp_qc_all, salt_all, salt_qc_all, & - deph_all, prof_temp_qc_all, prof_saln_qc_all) - use nfw_mod - - integer, intent(in) :: fid - integer, intent(inout) :: nprof - real(8), intent(inout), dimension(:) :: juld_all - real(8), intent(inout), dimension(:) :: lat_all, lon_all - character, intent(inout), dimension(:) :: pos_qc_all - real(8), intent(inout), dimension(:,:) :: temp_all - character, intent(inout), dimension(:,:) :: temp_qc_all - real(8), intent(inout), dimension(:,:) :: salt_all - character, intent(inout), dimension(:,:) :: salt_qc_all - real(8), intent(inout), dimension(:,:) :: deph_all - character, intent(inout), dimension(:) :: prof_temp_qc_all - character, intent(inout), dimension(:) :: prof_saln_qc_all - - character(STRLEN) :: fname - integer :: f - integer :: ncid - integer :: id - integer :: nlev - - open(10, file = 'infiles.txt') - do f = 1, fid - read(10, fmt = '(a)') fname - end do - close(10) - - print *, ' reading "', trim(fname), '"' - - call nfw_open(fname, nf_nowrite, ncid) - - ! nprof - ! - call nfw_inq_dimid(fname, ncid, 'N_PROF', id) - call nfw_inq_dimlen(fname, ncid, id, nprof) - - ! nlev - ! - call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id) - call nfw_inq_dimlen(fname, ncid, id, nlev) - - ! juld - ! - call nfw_inq_varid(fname, ncid, 'JULD', id) - call nfw_get_var_double(fname, ncid, id, juld_all(1 : nprof)) - - ! lat - ! - call nfw_inq_varid(fname, ncid, 'LATITUDE', id) - call nfw_get_var_double(fname, ncid, id, lat_all(1 : nprof)) - - ! lon - ! - call nfw_inq_varid(fname, ncid, 'LONGITUDE', id) - call nfw_get_var_double(fname, ncid, id, lon_all(1 : nprof)) - - ! pos_qc - ! - call nfw_inq_varid(fname, ncid, 'POSITION_QC', id) - call nfw_get_var_text(fname, ncid, id, pos_qc_all(1 : nprof)) - - ! temp - ! - call nfw_inq_varid(fname, ncid, 'POTM_CORRECTED', id) - call nfw_get_var_double(fname, ncid, id, temp_all(1 : nlev, 1 : nprof)) - - ! temp_qc - ! - call nfw_inq_varid(fname, ncid, 'POTM_CORRECTED_QC', id) - call nfw_get_var_text(fname, ncid, id, temp_qc_all(1 : nlev, 1 : nprof)) - - ! psal - ! - call nfw_inq_varid(fname, ncid, 'PSAL_CORRECTED', id) - call nfw_get_var_double(fname, ncid, id, salt_all(1 : nlev, 1 : nprof)) - - ! psal_qc - ! - call nfw_inq_varid(fname, ncid, 'PSAL_CORRECTED_QC', id) - call nfw_get_var_text(fname, ncid, id, salt_qc_all(1 : nlev, 1 : nprof)) - - ! deph - ! - call nfw_inq_varid(fname, ncid, 'DEPH_CORRECTED', id) - call nfw_get_var_double(fname, ncid, id, deph_all(1 : nlev, 1 : nprof)) - - ! profile_potm_qc - ! - call nfw_inq_varid(fname, ncid, 'PROFILE_POTM_QC', id) - call nfw_get_var_text(fname, ncid, id, prof_temp_qc_all(1 : nprof)) - - ! profile_psal_qc - ! - call nfw_inq_varid(fname, ncid, 'PROFILE_PSAL_QC', id) - call nfw_get_var_text(fname, ncid, id, prof_saln_qc_all(1 : nprof)) - - call nfw_close(fname, ncid) - end subroutine data_readfile - - real(8) function potential_density(T, S) - real(8), intent(in) :: T, S - - if (T < -2.0d0 .or. T > 40.0d0 .or. S < 0.0d0 .or. S > 42.0d0) then - potential_density = -999.0d0 - return - end if - - potential_density =& - -9.20601d-2& - + T * (5.10768d-2 + S * (- 3.01036d-3)& - + T * (- 7.40849d-3 + T * 3.32367d-5 + S * 3.21931d-5))& - + 8.05999d-1 * S - end function potential_density - - ! Purpose: find pivot points from profile data - ! - subroutine get_pivot(nx, ny, nprof, lon, lat, ipiv, jpiv, depths, modlon, modlat) - use m_get_micom_grid - use m_get_micom_dim - use m_pivotp_micom - - implicit none - - ! Grid dimensions - integer, intent(in) :: nx, ny - integer, intent(in) :: nprof - - real , intent(in) :: lon(nprof), lat(nprof) - integer, intent(inout) :: ipiv(nprof), jpiv(nprof) - - real, intent(inout), dimension(nx,ny) :: depths, modlon, modlat - - real, parameter :: onem=98060. - - character(len=80) :: filename - logical :: ex - character(len=8) :: ctmp - - real :: meandx,mindx - real, allocatable, dimension(:,:) :: min_r, max_r - integer, allocatable, dimension(:,:) :: itw, & - jtw, its, jts, itn, jtn, ite, jte - integer :: p - integer :: dimids(2) - integer :: ncid, x_ID, y_ID, z_ID - integer :: vJPIV_ID, vIPIV_ID - integer :: ncid2, jns_ID, ins_ID, inw_ID, jnw_ID,jnn_ID, inn_ID, ine_ID, jne_ID - - allocate(min_r(nx, ny)) - allocate(max_r(nx, ny)) - allocate(itw(nx, ny)) - allocate(jtw(nx, ny)) - allocate(its(nx, ny)) - allocate(jts(nx, ny)) - allocate(itn(nx, ny)) - allocate(jtn(nx, ny)) - allocate(ite(nx, ny)) - allocate(jte(nx, ny)) - - ! Read position and depth from model grid - ! - call get_micom_grid(modlon, modlat, depths, mindx, meandx, nx, ny) - call ini_pivotp(modlon,modlat, nx, ny, min_r, max_r, itw, jtw, itn, jtn, & - its, jts, ite, jte) - do p=1,nprof - ipiv(p) = 1 - jpiv(p) = 1 - if (lat(p) .ge. -90 .and. lat(p) .le. 89 .and. lon(p) .ge. -180 .and. lon(p) .le. 180) then - call pivotp_micom_new(lon(p), lat(p), modlon, modlat, ipiv(p), jpiv(p), & - nx, ny, min_r, max_r,itw, jtw, its, jts, itn, jtn, ite, jte) - end if - end do - end subroutine get_pivot - - ! Define the observation error variance as in Xie and Zhu, 2010 - ! - subroutine data_variance(obstype, depth, var) - - implicit none - - character(*), intent(in) :: obstype - real , intent(in) :: depth - - real, intent(inout) :: var - - if (trim(obstype) == 'TEM') then - var = 0.05 + 0.45 * exp(-0.002 * depth) - var = var ** 2.0 - elseif(trim(obstype) == 'SAL') then - var = 0.02 + 0.10 * exp(-0.008 * depth) - var = var ** 2.0 - else - print *, 'ERROR: data_variance(): the definition of variance is only available for and ' - print *, 'The inital variance in the file should be non-negative...' - stop - end if - end subroutine data_variance - - ! Purpose: read obervation uncertainties (instrumental and - ! representativeness error) from the pre-estimation. - ! Refer to Karspeck, A. (2016). - ! - subroutine data_obsunc(fname, obstype, depth_bnd, field) - use nfw_mod - - character(*), intent(in) :: fname - character(*), intent(in) :: obstype - real(8), intent(inout), dimension(:,:) :: depth_bnd - real(8), intent(inout), dimension(:,:,:) :: field - - integer :: ncid - integer :: id - - !print *, ' reading "', trim(fname), '"' - call nfw_open(trim(fname), nf_nowrite, ncid) - - ! depth_bnd - call nfw_inq_varid(trim(fname), ncid, 'depth_bnds', id) - call nfw_get_var_double(trim(fname), ncid, id, depth_bnd) - - ! Obs_Unc - call nfw_inq_varid(trim(fname), ncid, 'var_o', id) - call nfw_get_var_double(trim(fname), ncid, id, field) - - call nfw_close(trim(fname), ncid) - end subroutine data_obsunc - - ! Purpose: read obervation climatology - ! - subroutine data_obsmean(fname, obstype, depth, lon, lat, field) - use nfw_mod - - character(*), intent(in) :: fname - character(*), intent(in) :: obstype - real(8), intent(inout), dimension(:) :: depth, lon, lat - real(8), intent(inout), dimension(:,:,:) :: field - - integer :: ncid - integer :: id - !integer, dimension(4) :: ns, nc - -! print *, ' reading "', trim(fname), '"' - call nfw_open(trim(fname), nf_nowrite, ncid) - - ! depth - call nfw_inq_varid(trim(fname), ncid, 'depth', id) - call nfw_get_var_double(trim(fname), ncid, id, depth) - - ! lon - call nfw_inq_varid(trim(fname), ncid, 'lon', id) - call nfw_get_var_double(trim(fname), ncid, id, lon) - - ! lat - call nfw_inq_varid(trim(fname), ncid, 'lat', id) - call nfw_get_var_double(trim(fname), ncid, id, lat) - - ! Obs_mean - if (trim(obstype) == 'SAL') then - call nfw_inq_varid(trim(fname), ncid, 'salinity', id) - call nfw_get_var_double(trim(fname), ncid, id, field) - elseif (trim(obstype) == 'TEM') then - call nfw_inq_varid(trim(fname), ncid, 'temperature', id) - call nfw_get_var_double(trim(fname), ncid, id, field(:,:,:)) - ! Convert from Kelvin to Celcius - field = field - 273.15 - end if - - call nfw_close(trim(fname), ncid) - end subroutine data_obsmean - -end module m_read_EN4_profile diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_FFI_glider.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_FFI_glider.F90 deleted file mode 100755 index 07af0195..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_FFI_glider.F90 +++ /dev/null @@ -1,202 +0,0 @@ -! File: m_read_FFI_glider.F90 -! -! Created: November 2009 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Read glider data from text files by FFI into TOPAZ system -! -! Description: Data file(s) are defined by the string in the 4th line of -! "infile.data". It should have the following format: -! -! FFI -! GSAL | GTEM -! -! -! -! -! This is a very beta code, just to make an initial assessment. -! -! Modifications: none - -module m_read_FFI_glider - implicit none - - integer, parameter, private :: STRLEN = 512 - - public read_ffi_glider - - private grid_readxyz - -contains - - subroutine read_ffi_glider(fname, obstype, variance, nx, ny, data) - use mod_measurement - use m_confmap - use m_oldtonew - use m_pivotp - use m_bilincoeff - - character(*), intent(in) :: fname - character(*), intent(in) :: obstype - real, intent(in) :: variance - integer, intent(in) :: nx, ny - type(measurement), allocatable, intent(out) :: data(:) - - real, dimension(nx, ny) :: modlat, modlon, depths - real :: latnew, lonnew - - character(STRLEN) :: record - integer :: ios - integer :: r, nr, o, nobs, oo - - real :: tmp - type(measurement) :: obs - type(measurement), allocatable :: tmpdata(:) - - ! count number of records - ! - open(10, file = trim(fname), access = 'sequential', status = 'old', iostat = ios) - if (ios /= 0) then - print *, 'ERROR: read_FFI_glider(): could not open "', fname, '"' - end if - nr = 1 - do while(.true.) - read(10, *, iostat = ios) record - if (ios /= 0) then - exit - end if - nr = nr + 1 - end do - - print *, trim(fname), ': ', nr, ' lines' - if (nr == 0) then - print *, 'ERROR: read_FFI_glider(): "', fname, '": empty file?' - stop - end if - - allocate(data(nr)) - - close(10) - open(10, file = trim(fname), access = 'sequential', status = 'old') - nobs = 0 - do r = 1, nr - if (trim(obstype) == 'GSAL' .or. trim(obstype) == 'SAL') then - read(10, *, iostat = ios) obs % date, obs % lat, obs % lon, obs % depth, tmp, tmp, obs % d - elseif (trim(obstype) == 'GTEM' .or. trim(obstype) == 'TEM') then - read(10, *, iostat = ios) obs % date, obs % lat, obs % lon, obs % depth, tmp, obs % d, tmp - else - print *, trim(fname), ': unknown data type "', trim(obstype), '"' - stop - end if - if (obs % date <= 0) then - cycle - end if - nobs = nobs + 1 - data(nobs) = obs - end do - close(10) - - allocate(tmpdata(1 : nobs)) - tmpdata = data(1 : nobs) - deallocate(data) - allocate(data(nobs)) - data = tmpdata - deallocate(tmpdata) - - if (nobs == 0) then - print *, 'ERROR: read_FFI_glider(): "', trim(fname),& - '": no meaningful data for ', trim(obstype), ' found' - stop - end if - print *, trim(fname), ': ', nobs, ' records for ', trim(obstype) - - data % id = obstype - data % var = variance - data % status = .true. - data % ns = 0 - data % i_orig_grid = 0 - ! convert seconds since 1/1/1970 to days since 1/1/1950 - ! - ! data(1 : nobs) % date = data(1 : nobs) % date / 86400 + 7305 - - call confmap_init(nx, ny) - call grid_readxyz(nx, ny, modlat, modlon, depths) - do o = 1, nobs - call oldtonew(data(o) % lat, data(o) % lon, latnew, lonnew) - call pivotp(lonnew, latnew, data(o) % ipiv, data(o) % jpiv) - if (data(o) % ipiv < 1 .or. data(o) % jpiv < 1& - .or. data(o) % ipiv > nx - 1 .or. data(o) % jpiv > ny - 1) then - data(o) % status = .false. - else - call bilincoeff(modlon, modlat, nx, ny, data(o) % lon, data(o) % lat,& - data(o) % ipiv, data(o) % jpiv, data(o) % a1, data(o) % a2,& - data(o) % a3, data(o) % a4) - end if - end do - - ! some basic QC - where (data % depth < 0.0d0 .or. data % depth > 6000.0d0) - data % status = .false. - end where - if (trim(obstype) == 'TEM') then - where (data % d < -3.0d0 .or. data % d > 40.0d0) - data % status = .false. - end where - elseif (trim(obstype) == 'SAL') then - where (data % d < 30.0d0 .or. data % d > 40.0d0) - data % status = .false. - end where - end if - - allocate(tmpdata(1 : count(data % status))) - oo = 0 - do o = 1, nobs - if (data(o) % status) then - oo = oo + 1 - tmpdata(oo) = data(o) - end if - end do - nobs = oo - deallocate(data) - allocate(data(nobs)) - data = tmpdata - deallocate(tmpdata) - - end subroutine read_ffi_glider - - - ! Copied from m_read_ifremer_argo. - ! - subroutine grid_readxyz(nx, ny, lat, lon, depth) - integer, intent(in) :: nx, ny - real(8), dimension(nx, ny), intent(inout) :: lat, lon, depth - - logical :: exists - character(len = 128) :: fname - - fname = 'newpos.uf' - inquire(file = fname, exist = exists) - if (.not. exists) then - print *, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist' - stop - end if - open(10, file = fname, form = 'unformatted', status = 'old') - print *, ' grid_readxyz(): reading "', trim(fname), '"...' - read(10) lat, lon - close(10) - - write(fname, '(a, i3.3, a, i3.3, a)') 'depths', nx, 'x', ny, '.uf' - inquire(file = fname, exist = exists) - if (.not. exists) then - print*, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist' - stop - end if - open (unit = 10, file = fname, status = 'old', form = 'unformatted') - print *, ' grid_readxyz(): reading "', trim(fname), '"...' - read(10) depth - close(10) - end subroutine grid_readxyz - -end module m_read_FFI_glider diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_HadI_SST.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_HadI_SST.F90 deleted file mode 100755 index 7531476f..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_HadI_SST.F90 +++ /dev/null @@ -1,146 +0,0 @@ - module m_read_HadI_SST - -contains - - subroutine read_HadI_SST(fname,cens,data,modlon,modlat,depths,dlon,dlat,nrobs) - use mod_measurement - use mod_grid - use nfw_mod - - implicit none - - integer, intent(in) :: dlon,dlat - integer, intent(out) :: nrobs - type (measurement), intent(inout) :: data(:) - real, dimension(dlon,dlat), intent(in) :: depths,modlon,modlat - character(len=80), intent(in) :: fname - character(len=3), intent(in) :: cens - real(4) ,allocatable :: vsst(:,:,:,:), vsic(:,:,:,:) ,vsst2(:,:,:,:) - real(4) ,allocatable :: vlongitude(:), vlatitude(:) - integer :: vLON_ID,vLAT_ID - integer :: ncid,vSST_ID,i,j,k,imonth - integer :: vsic_ID,irec,nens - integer, allocatable :: ns(:), nc(:) - logical :: ex, ice_status - real :: lon, lat,sst,sst_sq - real(4), dimension(1) :: scalefac, addoffset, undef -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read observation file - read(cens,*) nens - nens=10 - allocate(vsst(dlon,dlat,1,nens)) - allocate(vsic(dlon,dlat,1,nens)) - allocate(vlongitude(dlon)) - allocate(vlatitude(dlat)) - allocate(ns(4)) - allocate(nc(4)) - - ns(1)=1 - ns(2)=1 - ns(3)=1 - ns(4)=1 - nc(1)=dlon - nc(2)=dlat - nc(3)=1 - nc(4)=nens - - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'Data file ', fname, ' not found.' - stop - end if - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_varid(fname, ncid,'sst', vSST_ID) - call nfw_inq_varid(fname, ncid,'longitude', vLON_ID) - call nfw_inq_varid(fname, ncid,'sic', vSIC_ID) - call nfw_inq_varid(fname, ncid,'latitude', vLAT_ID) - call nfw_get_att_real(fname, ncid, vSST_ID, '_FillValue', undef) - call nfw_get_vara_real(fname, ncid, vSST_ID, ns, nc, vsst) - call nfw_get_vara_real(fname, ncid, vSIC_ID, ns, nc, vsic) - nc(4)=1 - call nfw_get_var_real(fname, ncid, vLON_ID, vlongitude) - call nfw_get_var_real(fname, ncid, vLAT_ID, vlatitude) - !call nfw_get_vara_real(fname, ncid, vLON_ID, 1, dlon, vlongitude) - !call nfw_get_vara_real(fname, ncid, vLAT_ID, 1, dlat, vlatitude) - call nfw_close(fname, ncid) - !Convert from Kelvin to Celcius - where (vsst.ne.undef(1)) vsst=vsst-273.15 -#ifdef ANOMALY -!Read the monthly mean - allocate(vsst2(dlon,dlat,1,1)) - nc(4)=1 - print *, 'Start reading anom' - call nfw_open('mean_obs.nc', nf_nowrite, ncid) - print *, 'openning ID' - call nfw_inq_varid('mean_obs.nc', ncid,'sst', vSST_ID) - print *, 'reading ID' - call nfw_get_vara_real('mean_obs.nc', ncid, vSST_ID, ns, nc, vsst2) - print *, 'closing' - call nfw_close('mean_obs.nc', ncid) - print *, 'Finished reading anom' - !Convert from Kelvin to Celcius - where (vsst2.ne.undef(1)) vsst2=vsst2-273.15 - do k = 1, nens - where (vsst2(:,:,1,1).ne.undef(1)) vsst(:,:,1,k)=vsst(:,:,1,k)-vsst2(:,:,1,1) - enddo ! dlon -#endif - print *,'Nb obs mem' - nrobs=1 - do j = 1, dlat - do i = 1, dlon - sst=0. - sst_sq=0. - ice_status=.true. - do k = 1, nens - if (ice_status .and. vsic(i,j,1,k).eq.0. .and. vsst(i,j,1,k).ne.undef(1)) then - !convert from Kelvin to Celcius - sst=sst+vsst(i,j,1,k) - sst_sq=sst_sq+vsst(i,j,1,k)**2 - !Only fill with realistic value for the last member - data(nrobs)%d = 9999. - data(nrobs)%ipiv = i - data(nrobs)%jpiv = j - !regular grid [-179.5 -> 179.5] & [89.5 -> -89.5] - data(nrobs)%lon = vlongitude(i) - data(nrobs)%lat = vlatitude(j) - data(nrobs)%a1 = 1 - data(nrobs)%a2 = 0 - data(nrobs)%a3 = 0 - data(nrobs)%a4 = 0 - data(nrobs)%ns = 0 - data(nrobs)%depth = 0 - data(nrobs)%date = 0 - data(nrobs)%id ='SST' - data(nrobs)%orig_id =0 - data(nrobs)%i_orig_grid = -1 - data(nrobs)%j_orig_grid = -1 - data(nrobs)%h = 1 - data(nrobs)%date = 0 - data(nrobs)%status = .false. - if (k.eq.nens) then - data(nrobs)%status = .true. - ! calculate the variance of the ensemble of obs - !if nens=1 -> division by 0 - sst=sst/real(nens) - sst_sq=sst_sq/real(nens) - data(nrobs)%d = sst - !Add a min erro because some places obs spread is null - ! data(nrobs)%var = max(sst_sq-sst**2,0.01) -> min error of 0.1 - ! degree - data(nrobs)%var = max(sst_sq-sst**2,0.01) - nrobs=nrobs+1 - endif - else - ice_status=.false. - endif - enddo ! dlon - enddo ! dlat - enddo ! dlon - nrobs=nrobs-1 - print *,'Max,min obs',maxval(data(:)%d),minval(data(:)%d),maxval(data(:)%lon),minval(data(:)%lat) - print *,'Max,min age',maxval(data(:)%date),minval(data(:)%date) - print *,'Nb of obs',nrobs - ! print *,'Max,min lon',maxval(data(:)%lon),minval(data(:)%lon) - ! print *,'Max,min lat',maxval(data(:)%lat),minval(data(:)%lat) -end subroutine read_HadI_SST -end module m_read_HadI_SST diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST.F90 deleted file mode 100755 index f32ab2a9..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST.F90 +++ /dev/null @@ -1,102 +0,0 @@ -module m_read_MET_SST - ! Reads CLS SLA data after having read the grid in read_CLS_SST_grid - - integer, parameter, private :: STRLEN = 512 - -contains - - subroutine read_MET_SST(filename,gr,data) - use mod_measurement - use mod_grid - use m_spherdist - use netcdf - use nfw_mod - implicit none - - type (measurement), intent(inout) :: data(:) - type (grid), intent(inout) :: gr ! CLS measurement grid - character(len=80), intent(in) :: filename - - ! Variable ids - integer :: lon_ID, lat_ID,vsst_ID, vstd_ID, vmask_ID - ! Data arrays - real, allocatable :: sst(:,:), lon(:), lat(:), std(:,:) - integer, allocatable :: mask(:,:) - integer :: ncid ! observations - real, dimension(1) :: undef_sst - integer :: i, j, count1 - real, parameter :: eps = 0.01 ! test for undefined values - ! filen name - logical :: ex - - print *, 'read_MET_SST:' - - inquire(file=trim(filename),exist=ex) - if (ex) then - ! Reading the observation file - call nfw_open(filename, nf_nowrite, ncid) - ! Get dimension id in netcdf file ... - !nb total of data - allocate(lon(gr%nx), lat(gr%ny), sst(gr%nx,gr%ny), std(gr%nx, gr%ny), mask(gr%nx, gr%ny)) - - ! Variable ids in netcdf file - call nfw_inq_varid(filename, ncid, 'lat', lat_ID) - call nfw_inq_varid(filename, ncid,'lon', lon_ID) - call nfw_inq_varid(filename, ncid,'analysed_sst' ,vsst_ID) - call nfw_inq_varid(filename, ncid,'analysis_error' ,vstd_ID) - call nfw_inq_varid(filename, ncid,'mask' ,vmask_ID) - - ! Variable _FillValue attributes - call nfw_get_att_double(filename, ncid, vsst_ID, '_FillValue', undef_sst(1)) - gr % undef = undef_sst(1) - - ! actual variable values (for dimensions of var -- see ncdump, or improve this program) - ! NB: note that index dimensions are different between fortran and C internals. - ! "ncdump" gives C internals. - call nfw_get_var_double(filename, ncid, lon_ID, lon) - call nfw_get_var_double(filename, ncid, lat_ID, lat) - call nfw_get_var_double(filename, ncid, vsst_ID, sst) - call nfw_get_var_double(filename, ncid, vstd_ID, std) - call nfw_get_var_int(filename, ncid, vmask_ID, mask) - print '(1x, a, 2f10.2)', ' range Lon = ', minval(lon), maxval(lon) - print '(1x, a, 2f10.2)', ' range Lat = ', minval(lat), maxval(lat) - print '(1x, a, 2f10.2)', ' range sst (K) = ', minval(sst), maxval(sst) - print '(1x, a, 2i10)', ' range mask = ', minval(mask), maxval(mask) - call nfw_close(filename, ncid) - count1=1 - do i=1,gr%nx - do j=1,gr%ny - !here we only consider: - !data above -30 of lat; valid, within reasonable range, and with - !error variance <5 C^² - ! and only open ocean (mask == 1) - ! - if (lat(j) > -30 .and.& - abs(sst(i,j)-undef_sst(1)) > eps .and.& - mask(i,j) == 1 .and. & - sst(i,j) > -190 .and. & - sst(i,j) < 4500 .and. & - std(i,j) > 0.0 .and. & - std(i,j)<223.6) then - data(count1)%id = 'SST' - data(count1)%d = sst(i,j)*0.01 - data(count1)%ipiv = count1 !whatever it is filled afterwards - data(count1)%jpiv = 1 !whaterver it is filled afterwards - data(count1)%lat=lat(j) - data(count1)%lon=lon(i) - data(count1)%a1 = spherdist(lon(i)-.5*gr%dx,lat(j)-.5*gr%dy,lon(i)+.5*gr%dx,lat(j)+.5*gr%dy) - data(count1)%ns = 1 ! 1 for data with a spatial extent - data(count1)%var = (std(i,j) * 0.01 * 2) ** 2 ! Exaggerate, factor 2 - data(count1)%date = 0 - data(count1)%depth = 0.0 - data(count1)%status = .true. - count1=count1+1 - endif - enddo !i - enddo !j - print*, ' # of obs read = ', count1 - deallocate(lat, lon, sst, mask) - end if ! ex - print *, 'MAX var(SST) = ', maxval(data(1 : count1) % var) - end subroutine read_MET_SST -end module m_read_MET_SST diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST_grid.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST_grid.F90 deleted file mode 100755 index 5ef666aa..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_MET_SST_grid.F90 +++ /dev/null @@ -1,60 +0,0 @@ -module m_read_MET_SST_grid - ! Reads the CLS SST NetCDF dimensions -contains - subroutine read_MET_SST_grid(filename,gr) - !use mod_dimensions - use mod_grid - use nfw_mod - implicit none - - character(len=80), intent(in) :: filename - type(grid), intent(out) :: gr - logical :: ex - !dimension ids - integer :: lon_ID,lat_ID - - ! Array dimensions - integer :: nblon,nblat - - integer :: ncid - real, allocatable :: lat(:), lon(:) - - print *, 'read_MET_SST_grid():' - - gr = default_grid - inquire(file=trim(filename),exist=ex) - if(ex) then - call nfw_open(filename, nf_nowrite, ncid) - print *, ' found "', trim(filename), '"...' - ! Get dimension id in netcdf file ... - call nfw_inq_dimid(filename, ncid, 'lon', lon_ID) - call nfw_inq_dimid(filename, ncid, 'lat', lat_ID) - ! Get dimension length from id - call nfw_inq_dimlen(filename, ncid, lon_ID, nblon) - call nfw_inq_dimlen(filename, ncid, lat_ID, nblat) - print*, 'Dimensions lon,lat:', nblon, nblat - allocate(lon(nblon), lat(nblat)) - call nfw_inq_varid(filename, ncid, 'lon', lon_ID) - call nfw_inq_varid(filename, ncid, 'lat', lat_ID) - call nfw_get_var_double(filename, ncid, lon_ID, lon) - call nfw_get_var_double(filename, ncid, lat_ID, lat) - call nfw_close(filename, ncid) - - - gr%nx=nblon - gr%ny=nblat - gr%x0=lon(1) - gr%y0=lat(1) - gr%dx=lon(2)-lon(1) - gr%dy=lat(2)-lat(1) - - gr%reg = .true. - gr%order = 2 - gr%ux = 'm' - gr%uy = 'm' - gr%set = .true. - deallocate(lon,lat) - endif - end subroutine read_MET_SST_grid - -end module m_read_MET_SST_grid diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_NOAA_SST.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_NOAA_SST.F90 deleted file mode 100755 index 20bbdbe4..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_NOAA_SST.F90 +++ /dev/null @@ -1,118 +0,0 @@ - module m_read_NOAA_SST - -contains - - subroutine read_NOAA_SST(fname,cens,data,modlon,modlat,depths,dlon,dlat,nrobs) - use mod_measurement - use mod_grid - use nfw_mod - - implicit none - - integer, intent(in) :: dlon,dlat - integer, intent(out) :: nrobs - type (measurement), intent(inout) :: data(:) - real, dimension(dlon,dlat), intent(in) :: depths,modlon,modlat - character(len=80), intent(in) :: fname - character(len=3), intent(in) :: cens - real(4) ,allocatable :: vsst(:,:,:), vsic(:,:,:) ,vsst2(:,:,:),verr(:,:,:) - real(4) ,allocatable :: vlongitude(:), vlatitude(:) - integer :: vLON_ID,vLAT_ID,vERR_ID - integer :: ncid,vSST_ID,vSST2_ID,i,j,k,imonth - integer :: vsic_ID,irec,nens - integer, allocatable :: ns(:), nc(:) - logical :: ex, ice_status - real :: lon, lat,sst,sst_sq - real(4), dimension(1) :: scalefac_sst, addoffset_sst, scalefac_sic, addoffset_sic - integer :: dimids(2) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read observation file - read(cens,*) nens - allocate(vsst(dlon,dlat,1)) - allocate(vsic(dlon,dlat,1)) - allocate(verr(dlon,dlat,1)) - allocate(vlongitude(dlon)) - allocate(vlatitude(dlat)) - allocate(ns(3)) - allocate(nc(3)) - - ns(1)=1 - ns(2)=1 - ns(3)=1 - nc(1)=dlon - nc(2)=dlat - nc(3)=1 - - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'Data file ', fname, ' not found.' - stop - end if - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_varid(fname, ncid,'sst', vSST_ID) - call nfw_inq_varid(fname, ncid,'lon', vLON_ID) - call nfw_inq_varid(fname, ncid,'icec', vSIC_ID) - call nfw_inq_varid(fname, ncid,'err', vERR_ID) - call nfw_inq_varid(fname, ncid,'lat', vLAT_ID) - call nfw_get_vara_real(fname, ncid, vSST_ID, ns, nc, vsst) - call nfw_get_att_real(fname, ncid, vSST_ID, 'add_offset', addoffset_sst) - call nfw_get_att_real(fname, ncid, vSST_ID, 'scale_factor', scalefac_sst) - call nfw_get_vara_real(fname, ncid, vSIC_ID, ns, nc, vsic) - call nfw_get_att_real(fname, ncid, vSIC_ID, 'add_offset', addoffset_sic) - call nfw_get_att_real(fname, ncid, vSIC_ID, 'scale_factor', scalefac_sic) - call nfw_get_vara_real(fname, ncid, vERR_ID, ns, nc, verr) - call nfw_get_var_real(fname, ncid, vLON_ID, vlongitude) - call nfw_get_var_real(fname, ncid, vLAT_ID, vlatitude) - call nfw_close(fname, ncid) - do j = 1, dlat - do i = 1, dlon - vsst(i,j,1)=vsst(i,j,1)*scalefac_sst(1)+addoffset_sst(1) - vsic(i,j,1)=vsic(i,j,1)*scalefac_sic(1)+addoffset_sic(1) - enddo - enddo -#ifdef ANOMALY -!Read the monthly mean - allocate(vsst2(dlon,dlat,1)) - print *, 'Reading anom' - call nfw_open('mean_obs.nc', nf_nowrite, ncid) - call nfw_inq_varid('mean_obs.nc', ncid,'sst', vSST2_ID) - call nfw_get_vara_real('mean_obs.nc', ncid, vSST2_ID, ns, nc, vsst2) - call nfw_close('mean_obs.nc', ncid) - vsst(:,:,1)=vsst(:,:,1)-vsst2(:,:,1) -#endif - nrobs=0 - do j = 1, dlat - do i = 1, dlon - if (vsic(i,j,1).eq.0.) then - nrobs=nrobs+1 - data(nrobs)%d = vsst(i,j,1) - data(nrobs)%ipiv = 0 - data(nrobs)%jpiv = 0 - !regular grid [-179.5 -> 179.5] & [89.5 -> -89.5] - data(nrobs)%lon = vlongitude(i) - data(nrobs)%lat = vlatitude(j) - data(nrobs)%a1 = 1 - data(nrobs)%a2 = 0 - data(nrobs)%a3 = 0 - data(nrobs)%a4 = 0 - data(nrobs)%ns = 0 - data(nrobs)%depth = 0 - data(nrobs)%date = 0 - data(nrobs)%id ='SST' - data(nrobs)%orig_id =0 - data(nrobs)%i_orig_grid = -1 - data(nrobs)%j_orig_grid = -1 - data(nrobs)%h = 1 - data(nrobs)%date = 0 - data(nrobs)%status = .true. - data(nrobs)%var = max(real(verr(i,j,1)),0.01) - endif - enddo ! dlat - enddo ! dlon - print *,'Max,min obs',maxval(data(:)%d),minval(data(:)%d),maxval(data(:)%lon),minval(data(:)%lat) - print *,'Max,min age',maxval(data(:)%date),minval(data(:)%date) - print *,'Nb of obs',nrobs - ! print *,'Max,min lon',maxval(data(:)%lon),minval(data(:)%lon) - ! print *,'Max,min lat',maxval(data(:)%lat),minval(data(:)%lat) -end subroutine read_NOAA_SST -end module m_read_NOAA_SST diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_amsr_norsex.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_amsr_norsex.F90 deleted file mode 100755 index b9136cc1..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_amsr_norsex.F90 +++ /dev/null @@ -1,175 +0,0 @@ -! File: m_read_amsr_norsex.F90 -! -! Created: ??? -! -! Last modified: 29/06/2010 -! -! Purpose: Reads ICEC data -! -! Description: -! -! Modifications: -! 29/06/2010 PS: -! - set the maximum ICEC to 0.995 to match the model -! Prior history: -! Not documented. - - module m_read_amsr_norsex -! Reads amsr icec from NERSC (norsex) -! This will only work for northern hemisphere data - some minor corrections -! are needed for SH data - - integer, parameter, private :: STRLEN = 512 - -contains - subroutine read_amsr_norsex(fname,gr,data,obstype) - use mod_grid - use mod_measurement - implicit none - type (grid), intent(out) :: gr - character(len=*) ,intent(in) :: fname - type(measurement), allocatable, intent(out) :: data(:) - character(len=5) ,intent(in) :: obstype - - integer :: i, j,k, rlen - integer*1, allocatable :: iofldi1(:,:) - integer*4, allocatable :: iofldi4(:,:) - real *4, allocatable, dimension(:,:) :: lon,lat,icec - logical :: ex(3) - - ! The grid stuff should be made more consistent - KAL - gr = default_grid - gr%undef=120. - gr%nx=608 - gr%ny=896 - gr%order=2 - gr%ux='12.5 km' !Roughly - gr%uy='12.5 km' !Roughly - gr%set=.true. - print '(a,3e14.3)','undef : ', gr%undef - print *,' No of gridpoints: ', gridpoints(gr) - - ! Test for input files: - inquire(exist=ex(1),file='psn12lons_v2.dat') - inquire(exist=ex(2),file='psn12lats_v2.dat') - inquire(exist=ex(3),file=trim(fname)) - - if (any(.not.ex)) then - print *,'A file is missing:' - print *,'File flag: ',ex(1),' - name: psn12lons_v2.dat' - print *,'File flag: ',ex(2),' - name: psn12lats_v2.dat' - print *,'File flag: ',ex(3),' - name: '//trim(fname) - print *,'(read_amsr_norsex)' - call exit(1) - end if - - - ! Allocate fields and read input data - allocate(icec (gr%nx,gr%ny)) - allocate(lon (gr%nx,gr%ny)) - allocate(lat (gr%nx,gr%ny)) - allocate(iofldi1(gr%nx,gr%ny)) - allocate(iofldi4(gr%nx,gr%ny)) - allocate(data (gr%nx*gr%ny)) - - inquire(iolength=rlen) iofldi4 - open(10,file='psn12lons_v2.dat',status='old',form='unformatted',access='direct',recl=rlen) - read(10,rec=1) iofldi4 - close(10) -#if defined (LITTLE_ENDIAN) /* Lon/lat input files are big endian */ - do j=1,gr%ny - do i=1,gr%nx - call swapendian2(iofldi4(i,j),4) - end do - end do -#endif - lon = real(iofldi4,4) / 100000.0_4 - - - inquire(iolength=rlen) iofldi4 - open(10,file='psn12lats_v2.dat',status='old',form='unformatted',access='direct',recl=rlen) - read(10,rec=1) iofldi4 - close(10) -#if defined (LITTLE_ENDIAN) /* Lon/lat input files are big endian */ - do j=1,gr%ny - do i=1,gr%nx - call swapendian2(iofldi4(i,j),4) - end do - end do -#endif - lat = real(iofldi4, 4) / 100000.0_4 - - inquire(iolength=rlen) iofldi1 - open(10,file=trim(fname),status='old',form='unformatted',access='direct',recl=rlen) - read(10,rec=1) iofldi1 - close(10) - - icec=iofldi1 - where(icec>100) - icec = real(gr % undef, 4) - elsewhere - icec = icec / 100.0_4 - !LB tighten observed pack ice - !where (icec>0.9) icec = 1.0 - end where - ! PS 25/06/2010 0.995 is the max allowed by the model - where (0.995 <= icec .and. icec <= 1.0) - icec = 0.995 - end where - - - do j=1,gr%ny - do i=1,gr%nx - - k=(j-1)*gr%nx +i - - data(k)%id = obstype - data(k)%d = icec(i,j) - data(k)%jpiv = j - data(k)%ipiv = i - data(k)%lon=lon(i,j) - data(k)%lat=lat(i,j) - -!LB: Data support is assumed = a square grid cell -!support diameter stored in %a1 (tricky, isn't it ?) - data(k)%a1 = 12500. *sqrt(2.) ! AMSR-E grid diagonal - data(k)%ns = 1 ! 1 for obs with a spatial extent - - data(k)%status = .not. undefined(data(k)%d,gr) ! active data - ! PS 17.06.2010 - increased obs error at the ice edge - ! data(k)%var = 0.01 ! KAL 10% - data(k) % var = 0.01d0 + (0.5d0 - abs(0.5d0 - icec(i,j))) ** 2 - data(k) % depth = 0.0 - end do - end do - - call icec2nc(gr % nx, gr % ny, icec, lon, lat) -end subroutine read_amsr_norsex - -subroutine icec2nc(ni, nj, icec, lon, lat) - use nfw_mod - - integer, intent(in) :: ni - integer, intent(in) :: nj - real*4, intent(in) :: icec(ni, nj), lon (ni, nj), lat(ni, nj) - - character(STRLEN) :: fname - integer :: ncid - integer :: nij_id(2), icec_id, lon_id, lat_id - - fname = 'icec.nc'; - call nfw_create(fname, nf_clobber, ncid) - call nfw_def_dim(fname, ncid, 'ni', ni, nij_id(1)); - call nfw_def_dim(fname, ncid, 'nj', nj, nij_id(2)); - call nfw_def_var(fname, ncid, 'icec', nf_float, 2, nij_id, icec_id) - call nfw_def_var(fname, ncid, 'lon', nf_float, 2, nij_id, lon_id) - call nfw_def_var(fname, ncid, 'lat', nf_float, 2, nij_id, lat_id) - call nfw_enddef(fname, ncid) - - call nfw_put_var_real(fname, ncid, icec_id, icec) - call nfw_put_var_real(fname, ncid, lon_id, lon) - call nfw_put_var_real(fname, ncid, lat_id, lat) - call nfw_close(fname, ncid) -end subroutine icec2nc - -end module m_read_amsr_norsex diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_ifremer_argo.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_ifremer_argo.F90 deleted file mode 100755 index 73155d5b..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_ifremer_argo.F90 +++ /dev/null @@ -1,663 +0,0 @@ -! File: m_read_ifremer_argo.F90 -! -! Created: 25 Jan 2008 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Read Argo data from NetCDF files from IFREMER into TOPAZ -! system. -! -! Description: Data file(s) are defined by the string in the 4th line of -! "infile.data". It should have the following format: -! -! IFREMER -! SAL | TEM -! -! -! -! After that: -! 1. all profiles are read into two arrays, -! pres(1 : nlev, 1 : nprof) and v(1 : nlev, 1 : nprof), where -! nprof is the total number of profiles in all files, and -! nlev is the maximum number of horizontal levels for all -! profiles; -! 2. bad data (with qc flags other than '1' or '2' is discarded; -! 3. dry or outside locations are discarded -! 4. if there close profiles (in the same grid cell), the best -! one (with most data or the most recent) is retained -! -! Modifications: 17/08/2010 PS: skip discarding close profiles -! - -module m_read_ifremer_argo - implicit none - - integer, parameter, private :: STRLEN = 512 - real, parameter, private :: SAL_MIN = 32.0 - real, parameter, private :: SAL_MAX = 37.5 - real, parameter, private :: DENS_DIFF_MIN = -0.02 - logical, parameter, private :: DISCARD_CLOSE = .false. - - public read_ifremer_argo - - private data_inquire - private data_readfile - private potential_density - private grid_readxyz - -contains - - subroutine read_ifremer_argo(fnames, obstype, variance, nx, ny, data) - use mod_measurement - use m_oldtonew - use m_confmap - use m_bilincoeff - use m_pivotp - use nfw_mod - - character(*), intent(in) :: fnames - character(*), intent(in) :: obstype - real(8), intent(in) :: variance - integer, intent(in) :: nx, ny - type(measurement), allocatable, intent(out) :: data(:) - - character(STRLEN) :: fname - integer :: nfile, nprof, nlev - real(8), allocatable :: juld(:) - character, allocatable :: juld_qc(:) - real(8), allocatable :: lat(:), lon(:) - character, allocatable :: pos_qc(:) - real(8), allocatable :: pres(:,:) - character, allocatable :: pres_qc(:,:) - real(8), allocatable :: temp(:,:), salt(:, :) - character, allocatable :: temp_qc(:,:), salt_qc(:, :) - integer, allocatable :: ipiv(:), jpiv(:) - - real(8), dimension(nx, ny) :: modlat, modlon - real(8), dimension(nx, ny) :: depths - - integer :: f, l, p, np - integer, allocatable :: mask(:) - integer, allocatable :: mask2(:, :) - integer, allocatable :: fid(:); - integer, allocatable :: profid(:) - integer, allocatable :: done(:) - real(8) :: zmax, Q, Qbest, rho, rho_prev, rho_inc - integer :: best - integer :: p1 - - integer ngood, ndata - real(8) :: latnew, lonnew - - print *, 'BEGIN read_ifremer_argo()' - - call data_inquire(fnames, nfile, nprof, nlev) - print *, ' overall: nprof =', nprof, ', nlev =', nlev - - allocate(juld(nprof)) - allocate(juld_qc(nprof)) - allocate(lat(nprof)) - allocate(lon(nprof)) - allocate(pos_qc(nprof)) - allocate(fid(nprof)) - allocate(profid(nprof)) - allocate(pres(nlev, nprof)) - allocate(pres_qc(nlev, nprof)) - allocate(temp(nlev, nprof)) - allocate(salt(nlev, nprof)) - allocate(temp_qc(nlev, nprof)) - allocate(salt_qc(nlev, nprof)) - - p = 1 - do f = 1, nfile - call data_readfile(f, trim(obstype), np, juld(p : nprof),& - juld_qc(p : nprof), lat(p : nprof),& - lon(p : nprof), pos_qc(p : nprof), pres(1 : nlev, p : nprof),& - pres_qc(1 : nlev, p : nprof), temp(1 : nlev, p : nprof),& - temp_qc(1 : nlev, p : nprof), salt(1 : nlev, p : nprof),& - salt_qc(1 : nlev, p : nprof)) - fid(p : p + np - 1) = f - do l = 1, np - profid(p + l - 1) = l - end do - p = p + np - end do - - ! mask <- juld_qc, pos_qc, pres_qc, v_qc - ! - allocate(mask(nprof)) - mask(:) = 1 - allocate(mask2(nlev, nprof)) - mask2(:, :) = 1 - - where (juld_qc /= '1' .and. juld_qc /= '2') mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after examining JULD_QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - where (pos_qc /= '1' .and. pos_qc /= '2') mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after examining POS_QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! ipiv, jpiv - ! - allocate(ipiv(nprof)) - allocate(jpiv(nprof)) - ipiv(:) = -999 - jpiv(:) = -999 - call confmap_init(nx, ny) - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - call oldtonew(lat(p), lon(p), latnew, lonnew) - call pivotp(lonnew, latnew, ipiv(p), jpiv(p)) - end do - where (ipiv < 1 .or. jpiv < 1 .or. ipiv > nx - 1 .or. jpiv > ny - 1) mask = 0 - do p = 1, nprof - if (mask(p) == 0) then - mask2(:, p) = 0 - end if - end do - print *, ' after calculaling pivot points:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! - ! Now examine 3D quality flags; set the mask for a profile to 0 if there - ! are no good samples in this profile - ! - - ! pres_qc - ! - do p = 1, nprof - do l = 1, nlev - if (pres_qc(l, p) /= '1' .and. pres_qc(l, p) /= '2') then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - print *, ' after examining PRES_QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! _qc - ! - if (trim(obstype) == 'SAL') then - do p = 1, nprof - do l = 1, nlev - if (salt_qc(l, p) /= '1' .and. salt_qc(l, p) /= '2') then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - else if (trim(obstype) == 'TEM') then - do p = 1, nprof - do l = 1, nlev - if (temp_qc(l, p) /= '1' .and. temp_qc(l, p) /= '2') then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - end if - print *, ' after examining _QC:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Check for the observation being wet - ! - call grid_readxyz(nx, ny, modlat, modlon, depths) - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - if (pres(l, p) > depths(ipiv(p), jpiv(p)) .or.& - pres(l, p) > depths(ipiv(p) + 1, jpiv(p)) .or.& - pres(l, p) > depths(ipiv(p), jpiv(p) + 1) .or.& - pres(l, p) > depths(ipiv(p) + 1, jpiv(p) + 1)) then - mask2(l, p) = 0 - end if - end do - if (count(mask2(:, p) == 1) == 0) then - mask(p) = 0 - end if - end do - print *, ' after examining for wet cells:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! For salinity, allow SAL_MIN < S < SAL_MAX only in a profile - ! - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - if ((trim(obstype) == 'SAL' .and.& - (salt_qc(l, p) == '1' .or. salt_qc(l, p) == '2')) .and.& - (salt(l, p) < SAL_MIN .or. salt(l, p) > SAL_MAX)) then - mask(p) = 0 ! discard the profile - mask2(:, p) = 0 - exit - end if - end do - end do - print *, ' after keeping only profiles with salinity within',& - SAL_MIN, '<= S <=', SAL_MAX, ":" - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - print *, ' discarding convectionally unstable profiles:' - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - rho_prev = -999.0 - do l = 1, nlev - if (mask2(l, p) == 0 .or.& - (temp_qc(l, p) /= '1' .and. temp_qc(l, p) /= '2') .or.& - (salt_qc(l, p) /= '1' .and. salt_qc(l, p) /= '2')) then - cycle - end if - if (rho_prev == -999.0) then - rho_prev = potential_density(temp(l, p), salt(l, p)) - cycle - else - rho = potential_density(temp(l, p), salt(l, p)) - rho_inc = rho - rho_prev - if (rho_inc < DENS_DIFF_MIN) then - open(10, file = 'infiles.txt') - do f = 1, fid(p) - read(10, fmt = '(a)') fname - end do - close(10) - - print *, ' ', trim(fname), ':' - print *, ' profile #', profid(p), '( #', p, ')' - print *, ' level #', l - print *, ' rho increment =', rho_inc - mask(p) = 0 ! discard the profile - mask2(:, p) = 0 - exit - end if - rho_prev = rho - end if - end do - end do - print *, ' after discarding unstable profiles:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - - ! Finally, discard redundant observations - ! This is a O(n^2) search, which can become a bit long when the number of - ! examined profiles becomes really large (say, 10^4) - ! - if (DISCARD_CLOSE) then - allocate(done(nprof)) - done = 0 - do p = 1, nprof - if (mask(p) == 0 .or. done(p) == 1) then - cycle - end if - np = 1 - profid(np) = p - do p1 = p + 1, nprof - if (ipiv(p1) == ipiv(p) .and. jpiv(p1) == jpiv(p)) then - np = np + 1 - profid(np) = p1 - done(p1) = 1 - end if - end do - if (np > 1) then - ! for each of close profiles find the depth range, number of points - ! and the age - Qbest = 0.0 - do p1 = 1, np - zmax = 0.0 - ndata = 0 - do l = 1, nlev - if (mask2(l, p1) == 1) then - ndata = ndata + 1 - if (pres(l, profid(p1)) > zmax) then - zmax = pres(l, profid(p1)) - end if - end if - end do - Q = min(zmax, 400.0) / 400.0 + min(ndata, 10) / 10 - if (Q > Qbest) then - best = p1 - end if - end do - do p1 = 1, np - if (p1 == best) then - cycle - end if - mask(profid(p1)) = 0 - mask2(:, profid(p1)) = 0 - end do - end if - end do - deallocate(done) - print *, ' after discarding close profiles:' - print *, ' ', count(mask == 1), ' good profiles' - print *, ' ', count(mask2 == 1), ' good obs' - end if ! DISCARD_CLOSE - - ngood = count(mask2 == 1) - allocate(data(ngood)) - ndata = 0 - do p = 1, nprof - if (mask(p) == 0) then - cycle - end if - do l = 1, nlev - if (mask2(l, p) == 0) then - cycle - end if - - ndata = ndata + 1 - - if (ndata > ngood) then - print *, 'ERROR: read_ifremer_argo(): programming error' - print *, ' p =', p, ', l =', l - print *, ' # data =', ndata, ', ngood =', ngood - stop - end if - - ! PS: I guess we should not bother about the cost of the - ! comparisons below. - ! - if (trim(obstype) == 'SAL') then - data(ndata) % d = salt(l, p) - else if (trim(obstype) == 'TEM') then - data(ndata) % d = temp(l, p) - else - data(ndata) % d = -999.0 - end if - data(ndata) % var = variance - data(ndata) % id = obstype - data(ndata) % lon = lon(p) - data(ndata) % lat = lat(p) - data(ndata) % depth = max(0.0, pres(l, p)) - data(ndata) % ipiv = ipiv(p) - data(ndata) % jpiv = jpiv(p) - data(ndata) % ns = 0 ! for a point (not gridded) measurement - data(ndata) % date = 0 ! assimilate synchronously - - call bilincoeff(modlon, modlat, nx, ny, lon(p), lat(p), ipiv(p),& - jpiv(p), data(ndata) % a1, data(ndata) % a2, data(ndata) % a3,& - data(ndata) % a4) - - data(ndata) % status = .true. ! (active) - data(ndata) % i_orig_grid = p - data(ndata) % j_orig_grid = l - end do - end do - - if (ndata /= ngood) then - print *, 'ERROR: read_ifremer_argo(): programming error' - print *, ' ndata =', ndata, ', ngood =', ngood - stop - end if - - deallocate(juld) - deallocate(juld_qc) - deallocate(lat) - deallocate(lon) - deallocate(pos_qc) - deallocate(profid) - deallocate(pres) - deallocate(pres_qc) - deallocate(temp) - deallocate(salt) - deallocate(temp_qc) - deallocate(salt_qc) - deallocate(mask) - deallocate(mask2) - deallocate(ipiv) - deallocate(jpiv) - - print *, 'END read_ifremer_argo()' - - end subroutine read_ifremer_argo - - - subroutine data_inquire(fnames, nfile, nprof, nlev) - use nfw_mod - - character(*), intent(in) :: fnames - integer, intent(inout) :: nfile, nprof, nlev - - character(STRLEN) :: command ! (there may be a limit of 80 on some systems) - character(STRLEN) :: fname - integer :: ios - integer :: ncid - integer :: id - - integer :: nprof_this, nlev_this - - nfile = 0 - nprof = 0 - nlev = 0 - - command = 'ls '//trim(fnames)//' > infiles.txt' - call system(command); - - nfile = 0 - open(10, file = 'infiles.txt') - do while (.true.) - read(10, fmt = '(a)', iostat = ios) fname - if (ios /= 0) then - exit - end if - - nfile = nfile + 1 - print *, ' file #', nfile, ' = "', trim(fname), '"' - - call nfw_open(fname, nf_nowrite, ncid) - - ! nprof - ! - call nfw_inq_dimid(fname, ncid, 'N_PROF', id) - call nfw_inq_dimlen(fname, ncid, id, nprof_this) - print *, ' nprof = ', nprof_this - - ! nlev - ! - call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id) - call nfw_inq_dimlen(fname, ncid, id, nlev_this) - print *, ' nlev = ', nlev_this - - nprof = nprof + nprof_this - if (nlev_this > nlev) then - nlev = nlev_this - end if - - call nfw_close(fname, ncid) - end do - close(10) - end subroutine data_inquire - - - subroutine data_readfile(fid, obstype, nprof, juld_all, juld_qc_all,& - lat_all, lon_all, pos_qc_all, pres_all, pres_qc_all, temp_all, temp_qc_all, salt_all, salt_qc_all) - use nfw_mod - - integer, intent(in) :: fid - character(*), intent(in) :: obstype - integer, intent(inout) :: nprof - real(8), intent(inout), dimension(:) :: juld_all - character, intent(inout), dimension(:) :: juld_qc_all - real(8), intent(inout), dimension(:) :: lat_all, lon_all - character, intent(inout), dimension(:) :: pos_qc_all - real(8), intent(inout), dimension(:,:) :: pres_all - character, intent(inout), dimension(:,:) :: pres_qc_all - real(8), intent(inout), dimension(:,:) :: temp_all - character, intent(inout), dimension(:,:) :: temp_qc_all - real(8), intent(inout), dimension(:,:) :: salt_all - character, intent(inout), dimension(:,:) :: salt_qc_all - - character(STRLEN) :: fname - integer :: f - integer :: ncid - integer :: id - integer :: nlev - - open(10, file = 'infiles.txt') - do f = 1, fid - read(10, fmt = '(a)') fname - end do - close(10) - - print *, ' reading "', trim(fname), '"' - - call nfw_open(fname, nf_nowrite, ncid) - - ! nprof - ! - call nfw_inq_dimid(fname, ncid, 'N_PROF', id) - call nfw_inq_dimlen(fname, ncid, id, nprof) - - ! nlev - ! - call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id) - call nfw_inq_dimlen(fname, ncid, id, nlev) - - ! juld - ! - call nfw_inq_varid(fname, ncid, 'JULD', id) - call nfw_get_var_double(fname, ncid, id, juld_all(1 : nprof)) - - ! juld_qc - ! - call nfw_inq_varid(fname, ncid, 'JULD_QC', id) - call nfw_get_var_text(fname, ncid, id, juld_qc_all(1 : nprof)) - - ! lat - ! - call nfw_inq_varid(fname, ncid, 'LATITUDE', id) - call nfw_get_var_double(fname, ncid, id, lat_all(1 : nprof)) - - ! lon - ! - call nfw_inq_varid(fname, ncid, 'LONGITUDE', id) - call nfw_get_var_double(fname, ncid, id, lon_all(1 : nprof)) - - ! pos_qc - ! - call nfw_inq_varid(fname, ncid, 'POSITION_QC', id) - call nfw_get_var_text(fname, ncid, id, pos_qc_all(1 : nprof)) - - ! pres - ! - call nfw_inq_varid(fname, ncid, 'PRES', id) - call nfw_get_var_double(fname, ncid, id, pres_all(1 : nlev, 1 : nprof)) - - ! pres_qc - ! - call nfw_inq_varid(fname, ncid, 'PRES_QC', id) - call nfw_get_var_text(fname, ncid, id, pres_qc_all(1 : nlev, 1 : nprof)) - - ! temp - ! - call nfw_inq_varid(fname, ncid, 'TEMP', id) - call nfw_get_var_double(fname, ncid, id, temp_all(1 : nlev, 1 : nprof)) - - ! temp_qc - ! - call nfw_inq_varid(fname, ncid, 'TEMP_QC', id) - call nfw_get_var_text(fname, ncid, id, temp_qc_all(1 : nlev, 1 : nprof)) - - if (nfw_var_exists(ncid, 'PSAL')) then - ! psal - ! - call nfw_inq_varid(fname, ncid, 'PSAL', id) - call nfw_get_var_double(fname, ncid, id, salt_all(1 : nlev, 1 : nprof)) - - ! psal_qc - ! - call nfw_inq_varid(fname, ncid, 'PSAL_QC', id) - call nfw_get_var_text(fname, ncid, id, salt_qc_all(1 : nlev, 1 : nprof)) - else - salt_qc_all = 'E'; - end if - - call nfw_close(fname, ncid) - end subroutine data_readfile - - - subroutine grid_readxyz(nx, ny, lat, lon, depth) - integer, intent(in) :: nx, ny - real(8), dimension(nx, ny), intent(inout) :: lat, lon, depth - - logical :: exists - character(len = 128) :: fname - - fname = 'newpos.uf' - inquire(file = fname, exist = exists) - if (.not. exists) then - print *, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist' - stop - end if - open(10, file = fname, form = 'unformatted', status = 'old') - print *, ' grid_readxyz(): reading "', trim(fname), '"...' - read(10) lat, lon - close(10) - - write(fname, '(a, i3.3, a, i3.3, a)') 'depths', nx, 'x', ny, '.uf' - inquire(file = fname, exist = exists) - if (.not. exists) then - print*, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist' - stop - end if - open (unit = 10, file = fname, status = 'old', form = 'unformatted') - print *, ' grid_readxyz(): reading "', trim(fname), '"...' - read(10) depth - close(10) - end subroutine grid_readxyz - - - real(8) function potential_density(T, S) - real(8), intent(in) :: T, S - - if (T < -2.0d0 .or. T > 40.0d0 .or. S < 0.0d0 .or. S > 42.0d0) then - potential_density = -999.0d0 - return - end if - - potential_density =& - -9.20601d-2& - + T * (5.10768d-2 + S * (- 3.01036d-3)& - + T * (- 7.40849d-3 + T * 3.32367d-5 + S * 3.21931d-5))& - + 8.05999d-1 * S - end function potential_density - -end module m_read_ifremer_argo diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_metno_icec.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_metno_icec.F90 deleted file mode 100755 index c504502e..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_metno_icec.F90 +++ /dev/null @@ -1,106 +0,0 @@ -module m_read_metno_icec - -contains - - subroutine read_metno_icec(fname, data, gr) - use nfw_mod - use mod_measurement - use mod_grid - implicit none - - character(*), intent(in) :: fname - type (measurement), allocatable, intent(out) :: data(:) - type(grid), intent(out) :: gr - - logical :: ex - integer :: ncid - integer :: xc_id, yc_id - integer :: nx, ny - integer :: lon_id, lat_id, icec_id, std_id, flag_id - real, allocatable :: lon(:,:), lat(:,:), icec(:,:), std(:, :) - integer, allocatable :: flag(:,:) - - integer :: i, j, nobs - - print *, 'reading "', trim(fname), '"...' - - inquire(file = trim(fname), exist = ex) - if (.not. ex) then - print *, 'ERROR: file "', trim(fname), '" not found' - stop - end if - - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_dimid(fname, ncid, 'xc', xc_id) - call nfw_inq_dimid(fname, ncid, 'yc', yc_id) - call nfw_inq_dimlen(fname, ncid, xc_id, nx) - call nfw_inq_dimlen(fname, ncid, yc_id, ny) - print *, ' nx = ', nx - print *, ' ny = ', ny - allocate(lon(nx, ny)) - allocate(lat(nx, ny)) - allocate(icec(nx, ny)) - allocate(std(nx, ny)) - allocate(flag(nx, ny)) - call nfw_inq_varid(fname, ncid, 'lon', lon_id) - call nfw_inq_varid(fname, ncid, 'lat', lat_id) - call nfw_inq_varid(fname, ncid, 'ice_conc', icec_id) - call nfw_inq_varid(fname, ncid, 'standard_error', std_id) - call nfw_inq_varid(fname, ncid, 'status_flag', flag_id) - call nfw_get_var_double(fname, ncid, lon_id, lon) - call nfw_get_var_double(fname, ncid, lat_id, lat) - call nfw_get_var_double(fname, ncid, icec_id, icec) - call nfw_get_var_double(fname, ncid, std_id, std) - call nfw_get_var_int(fname, ncid, flag_id, flag) - call nfw_close(fname, ncid) - - print *, 'filling the measurements array...' - - allocate(data(nx * ny)) - - ! 0.995 is the max allowed by the model - where (99.5d0 <= icec .and. icec <= 100.0d0) - icec = 99.5d0 - end where - - nobs = 0 - do j = 1, ny - do i = 1, nx - nobs = nobs + 1 - if (flag(i, j) /= 0) then - data(nobs) % status = .false. - cycle - end if - data(nobs) % id = 'ICEC' - data(nobs) % d = icec(i, j) * 1d-4 - data(nobs) % var = max(1d-8 * std(i, j) ** 2, 0.01d0 + (0.5d0 - abs(0.5d0 - data(nobs) % d)) ** 2) - data(nobs) % ipiv = i - data(nobs) % jpiv = j - data(nobs) % lon = lon(i, j) - data(nobs) % lat = lat(i, j) - data(nobs) % a1 = 1e10 - data(nobs) % a2 = 1e10 - data(nobs) % a3 = 1e10 - data(nobs) % a4 = 1e10 - data(nobs) % ns = 1 - data(nobs) % date = 0 - data(nobs) % depth = 0.0 - data(nobs) % status = .true. - end do - end do - print *, ' ', nobs, 'primary ICEC observations' - print *, ' ', minval(data % d), ' <= icec <= ', maxval(data % d) - - gr = default_grid - gr % nx = nx - gr % ny = ny - gr%reg = .true. - gr % order = 2 - gr%ux = '10 km' - gr%uy = '10 km' - gr%set = .true. - - deallocate(lat, lon, icec, std, flag) - end subroutine read_metno_icec - -end module m_read_metno_icec diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SSH.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SSH.F90 deleted file mode 100755 index e1821832..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SSH.F90 +++ /dev/null @@ -1,64 +0,0 @@ - module m_read_micom_SSH - -contains - - subroutine read_micom_SSH(fname,cmonth,data,modlon, modlat, depths,nx,ny) - use mod_measurement - use mod_grid - use nfw_mod - - implicit none - - integer, intent(in) :: nx,ny - type (measurement), intent(inout) :: data(:) - real, dimension(nx,ny), intent(in) :: modlon,modlat,depths - character(len=80), intent(in) :: fname,cmonth - real(4) :: vssh(nx,ny,12) - integer :: ncid,vSSH_ID,i,j,k,imonth - logical :: ex, found, fleeting - real :: lon, lat - real(4), dimension(1) :: scalefac, addoffset -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read observation file - read(cmonth,'(i3.3)') imonth - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'Data file ', fname, ' not found.' - stop - end if - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_varid(fname, ncid,'sealv', vSSH_ID) - call nfw_get_var_real(fname, ncid, vSSH_ID, vssh) - call nfw_get_att_real(fname, ncid, vSSH_ID, 'add_offset', addoffset) - call nfw_get_att_real(fname, ncid, vSSH_ID, 'scale_factor', scalefac) - k=1 - do j = 1, ny - do i = 1, nx - if (depths(i,j)>0 .and. vssh(i,j,imonth)*scalefac(1)+addoffset(1)>-10 ) then - data(k)%d = vssh(i,j,imonth)*scalefac(1)+addoffset(1) - data(k)%ipiv = i - data(k)%jpiv = j - data(k)%lon = modlon(i,j) - data(k)%lat = modlat(i,j) - data(k)%a1 = 1 - data(k)%a2 = 0 - data(k)%a3 = 0 - data(k)%a4 = 0 - data(k)%ns = 0 - data(k)%var = 0.0009 - data(k)%depth = 0 - data(k)%date = 0 - data(k)%status = .true. - data(k)%id = 'SSH' - data(k)%orig_id =0 - data(k)%i_orig_grid = -1 - data(k)%j_orig_grid = -1 - data(k)%h = 1 - k=k+1 - endif - enddo ! ny - enddo ! nx - !print *,'number of obs',k-1 - !print *,'Max,min obs',maxval(data(:)%d),minval(data(:)%d),maxval(depths(:,:)),minval(depths(:,:)) -end subroutine read_micom_SSH -end module m_read_micom_SSH diff --git a/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SST.F90 b/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SST.F90 deleted file mode 100755 index e610c81e..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_read_micom_SST.F90 +++ /dev/null @@ -1,77 +0,0 @@ - module m_read_micom_SST - -contains - - subroutine read_micom_SST(fname,cmonth,data,modlon, modlat, depths,nx,ny,nrobs) - use mod_measurement - use mod_grid - use nfw_mod - - implicit none - - integer, intent(in) :: nx,ny - integer, intent(out) :: nrobs - type (measurement), intent(inout) :: data(:) - real, dimension(nx,ny), intent(in) :: modlon,modlat,depths - character(len=80), intent(in) :: fname,cmonth - real(4) :: vsst(nx,ny,1) - real(4) :: vfice(nx,ny) - integer :: ncid,vSST_ID,i,j,k,imonth - integer :: vFICE_ID - logical :: ex, found, fleeting - real :: lon, lat - real(4), dimension(1) :: scalefac, addoffset -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read observation file - vfice(:,:)=0 - inquire (file='mask.nc', exist=ex) - if (ex) then - print *,'Masking sst under cice' - call nfw_open('mask.nc', nf_nowrite, ncid) - call nfw_inq_varid('mask.nc', ncid,'ficem', vFICE_ID) - call nfw_get_var_real('mask.nc', ncid, vFICE_ID, vfice) - call nfw_close('mask.nc', ncid) - !no offset or scaling factor - endif - - inquire (file=fname, exist=ex) - if (.not. ex) then - print *, 'Data file ', fname, ' not found.' - stop - end if - call nfw_open(fname, nf_nowrite, ncid) - call nfw_inq_varid(fname, ncid,'sst', vSST_ID) - call nfw_get_var_real(fname, ncid, vSST_ID, vsst) - !call nfw_get_att_real(fname, ncid, vSST_ID, 'add_offset', addoffset) - !call nfw_get_att_real(fname, ncid, vSST_ID, 'scale_factor', scalefac) - k=1 - do j = 1, ny - do i = 1, nx - if (depths(i,j)>0 .and. vsst(i,j,1)>-1.81 .and. vfice(i,j)==0) then - data(k)%d = vsst(i,j,1) - data(k)%ipiv = i - data(k)%jpiv = j - data(k)%lon = modlon(i,j) - data(k)%lat = modlat(i,j) - data(k)%a1 = 1 - data(k)%a2 = 0 - data(k)%a3 = 0 - data(k)%a4 = 0 - data(k)%ns = 0 - data(k)%var = 0.01 - data(k)%depth = 0 - data(k)%date = 0 - data(k)%status = .true. - data(k)%id ='SST' - data(k)%orig_id =0 - data(k)%i_orig_grid = -1 - data(k)%j_orig_grid = -1 - data(k)%h = 1 - k=k+1 - endif - enddo ! ny - enddo ! nx - nrobs=k-1 - !print *,'Max,min obs',maxval(data(:)%d),minval(data(:)%d),maxval(depths(:,:)),minval(depths(:,:)) -end subroutine read_micom_SST -end module m_read_micom_SST diff --git a/assim/enkf_cf-system2_old/prep_obs/m_superobs.F90 b/assim/enkf_cf-system2_old/prep_obs/m_superobs.F90 deleted file mode 100755 index cd2980f4..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_superobs.F90 +++ /dev/null @@ -1,328 +0,0 @@ -! File: m_superobs.F90 -! -! Created: 02 Sep 2008 -! -! Author: Pavel Sakov -! NERSC -! -! Purpose: Superobing observations to model grid (one observation/profile only per grid) -! -! Description: Adapted from algorithm of Pavel SAKOV -! Conducts the following operations: -! - determine the number of observations with this tag -! - sort observations according to the pivot values -! - calculate superobs -! -! Modifications: 14.10.2009 PS: added cycle over the data age, so that it only -! superobs the data of the same age. Do not set -! age if you assiilate data of different age in -! one go. -! 15.11.2009 PS: fixed a defect at l.102: it should be -! "thisob = obs_now(sorted(o))", not -! "thisob = obs_now(o)" -! 17.11.2009 PS: extended to handle the 3D case -! 02.03.2016 Yiguo Wang: modify the definition of kpiv using -! the intrinsic function INT instead of z2k -! -module m_superobs - use mod_measurement - use m_bilincoeff - implicit none - - integer, parameter, private :: STRLEN = 512 - logical, parameter, private :: TEST = .false. - - contains - - subroutine superob(obstag, nobs, obs, ni, nj, modlon, modlat, nnewobs, newobs, is3d) - character(*), intent(in) :: obstag - integer, intent(in) :: nobs - type(measurement), intent(inout), dimension(:) :: obs - integer, intent(in) :: ni, nj - real, dimension(:,:), intent(in) :: modlon, modlat - integer, intent(inout) :: nnewobs - type(measurement), intent(inout), dimension(:) :: newobs - logical, intent(in), optional :: is3d - - integer :: age_min, age_max, nobs_total, nobs_now, age - integer :: o, iprev, jprev, kprev, ii, ii_now - logical, dimension(nobs) :: mask - integer, dimension(nobs) :: sorted - type(measurement), dimension(nobs) :: obs_now - real(8), dimension(1) :: nobs_real - type(measurement) :: thisob - real :: n, nmax, valsum, valsqsum, varinvsum, lonsum, latsum, depthsum, valmax, valmin - real :: a1sum, a2sum, a3sum, a4sum - integer :: nlon_pos, nlon_neg - real :: lonsum_abs - integer, dimension(nobs) :: kpiv ! vertical index for 3D case - integer, dimension(nobs) :: ids ! ids of obs contributing to this superob - integer :: fid - - print *, 'BEGIN superob()' - - ! find the range of the data age - ! - age_min = minval(obs (1:nobs) % date) - age_max = maxval(obs (1:nobs) % date) - print *, ' min age =', age_min - print *, ' max age =', age_max - - ! get the total number of observations to process - ! - mask = .false. - do o = 1, nobs - if (trim(obs(o) % id) == trim(obstag)) then - mask(o) = .true. - end if - obs(o) % orig_id = o - end do - nobs_total = count(mask) - print *, ' total # of obs of all types =', nobs - print *, ' total # of obs of type "', trim(obstag), '" =', nobs_total - - if (TEST) then - open(101, file = 'superobs.txt', access = 'sequential', status = 'replace') - end if - - ii = 0 - do age = age_min, age_max - ! trim() prevents vectorising below - mask = .false. - do o = 1, nobs - if (trim(obs(o) % id) == trim(obstag) .and. obs(o) % date == age .and. obs(o) % status) then - mask(o) = .true. - end if - end do - - nobs_now = count(mask) - print *, ' age =', age - print *, ' nobs =', nobs_now - - if (nobs_now == 0) then - cycle - end if - - obs_now(1 : nobs_now) = pack(obs(1 : nobs), mask) - - nobs_real(1) = nobs_now - if (.not. present(is3d) .or. .not. is3d) then - kpiv = 0 - call sortgriddedobs(nobs_real, obs_now % ipiv, obs_now % jpiv, sorted) - else - kpiv = z2k(obs_now % depth) !int(obs_now % depth) - call sortgriddedobs3d(nobs_real, obs_now % ipiv, obs_now % jpiv,& - kpiv, sorted) - end if - - iprev = 0 - jprev = 0 - kprev = 0 - nmax = 0 - ii_now = 0 - do o = 1, nobs_now + 1 - if (o <= nobs_now) then - thisob = obs_now(sorted(o)) - else - thisob % ipiv = -1 ! to force write of the previous measurement - end if - if (thisob % ipiv /= iprev .or. thisob % jpiv /= jprev .or. kpiv(sorted(o)) /= kprev) then - if (ii_now > 0) then ! write the previous measurement - newobs(ii) % d = valsum / n - if (is3d) then - newobs(ii) % var = varinvsum / n - else - newobs(ii) % var = 1.0d0 / varinvsum - end if - newobs(ii) % id = obstag - if (nlon_pos == 0 .or. nlon_neg == 0 .or. lonsum_abs / n < 90.0d0) then - newobs(ii) % lon = lonsum / n - else - lonsum = lonsum + real(nlon_neg) * 360.0d0; - newobs(ii) % lon = lonsum / n - if (newobs(ii) % lon > 180.0d0) then - newobs(ii) % lon = newobs(ii) % lon - 360.0d0 - end if - end if - newobs(ii) % lat = latsum / n - newobs(ii) % depth = depthsum / n - newobs(ii) % ipiv = iprev - newobs(ii) % jpiv = jprev - newobs(ii) % ns = 0 ! not 100% sure - newobs(ii) % a1 = a1sum / n - newobs(ii) % a2 = a2sum / n - newobs(ii) % a3 = a3sum / n - newobs(ii) % a4 = a4sum / n - newobs(ii) % status = .true. - newobs(ii) % i_orig_grid = -1 - newobs(ii) % j_orig_grid = -1 - newobs(ii) % h = n - newobs(ii) % date = age - newobs(ii) % orig_id = ids(1) ! ID of the first ob - nmax = max(n, nmax) - if (TEST) then - write(101, '(a, g10.3)') 'total # of obs = ', n - write(101, '(a, i6)') ' index = ', ii - write(101, '(a, g10.3)') ' d = ', newobs(ii) % d - write(101, '(a, g10.3)') ' var = ', newobs(ii) % var - write(101, '(a, g10.3)') ' lon = ', newobs(ii) % lon - write(101, '(a, g10.3)') ' lat = ', newobs(ii) % lat - write(101, '(a, i4)') ' ipiv = ', newobs(ii) % ipiv - write(101, '(a, i4)') ' jpiv = ', newobs(ii) % jpiv - write(101, '(a, g10.3)') ' depth = ', newobs(ii) % depth - write(101, '(a, g10.3)') ' a1 = ', newobs(ii) % a1 - write(101, '(a, g10.3)') ' a2 = ', newobs(ii) % a2 - write(101, '(a, g10.3)') ' a3 = ', newobs(ii) % a3 - write(101, '(a, g10.3)') ' a4 = ', newobs(ii) % a4 - write(101, '(a)') '---' - call superobs_dump(trim(obstag), ii, ids, int(n)) - end if - end if - if (o > nobs_now) then - exit - end if - ii = ii + 1 - ii_now = ii_now + 1 - if (TEST) then - write(101, '(a, i6)') 'new superob, index = ', ii - end if - n = 0.0 - valsum = 0.0d0 - valsqsum = 0.0d0 - varinvsum = 0.0d0 - lonsum = 0.0d0 - latsum = 0.0d0 - depthsum = 0.0 - a1sum = 0.0d0 - a2sum = 0.0d0 - a3sum = 0.0d0 - a4sum = 0.0d0 - valmax = -1.0d+20 - valmin = 1.0d+20 - iprev = thisob % ipiv - jprev = thisob % jpiv - kprev = kpiv(sorted(o)) - nlon_pos = 0 - nlon_neg = 0 - lonsum_abs = 0.0d0 - end if - n = n + 1.0 - valsum = valsum + thisob % d - valsqsum = valsqsum + (thisob % d) ** 2 - if (is3d) then - varinvsum = varinvsum + thisob % var - else - varinvsum = varinvsum + 1.0 / thisob % var - end if - lonsum = lonsum + thisob % lon - lonsum_abs = lonsum_abs + abs(thisob % lon) - if (thisob % lon >= 0.0) then - nlon_pos = nlon_pos + 1 - else - nlon_neg = nlon_neg + 1 - end if - latsum = latsum + thisob % lat - depthsum = depthsum + thisob % depth - a1sum = a1sum + thisob % a1 - a2sum = a2sum + thisob % a2 - a3sum = a3sum + thisob % a3 - a4sum = a4sum + thisob % a4 - valmin = min(valmin, thisob % d) - valmax = max(valmax, thisob % d) - ids(int(n)) = thisob % orig_id; - if (TEST) then - write(101, '(a, i6)') ' obs index = ', sorted(o) - write(101, '(a, g10.3)') ' d = ', thisob % d - write(101, '(a, g10.3)') ' var = ', thisob % var - write(101, '(a, g10.3)') ' lon = ', thisob % lon - write(101, '(a, g10.3)') ' lat = ', thisob % lat - write(101, '(a, i4)') ' ipiv = ', thisob % ipiv - write(101, '(a, i4)') ' jpiv = ', thisob % jpiv - write(101, '(a, g10.3)') ' depth = ', thisob % depth - write(101, '(a, g10.3)') ' a1 = ', thisob % a1 - write(101, '(a, g10.3)') ' a2 = ', thisob % a2 - write(101, '(a, g10.3)') ' a3 = ', thisob % a3 - write(101, '(a, g10.3)') ' a4 = ', thisob % a4 - end if - end do ! obs for this age - print *, ' nsuperobs =', ii_now - end do ! age - if (TEST) then - close(101) - end if - - nnewobs = ii - print *, ' superobing("', trim(obstag), '"):' - print *, ' ', nobs, 'observations ->', nnewobs, 'observations' - print *, ' ', 'max # of obs found in a grid cell =', int(nmax) - print *, 'END superob()' - end subroutine superob - - function z2k(z) - real, intent(in), dimension(:) :: z - integer, dimension(size(z)) :: z2k - - real, dimension(2, 42) :: depth_bnds - integer :: i, k, nz - - - nz = size(z) - depth_bnds = reshape((/0.0, 10.0475, 10.0475, 20.1158, 20.1158, 30.214, 30.214, 40.3553, 40.3553, 50.5586, & - 50.5586, 60.8509, 60.8509, 71.2711, 71.2711, 81.8753, 81.8753, 92.7437, 92.7437, 103.9913, & - 103.9913, 115.7825, 115.7825, 128.3522, 128.3522, 142.0345, 142.0345, 157.3019, 157.3019, 174.8189,& - 174.8189, 195.5097, 195.5097, 220.6418, 220.6418, 251.9186, 251.9186, 291.5638, 291.5638, 342.3651,& - 342.3651, 407.6244, 407.6244, 490.9494, 490.9494, 595.8501, 595.8501, 725.1709, 725.1709, 880.5102,& - 880.5102, 1061.846, 1061.846, 1267.542, 1267.542, 1494.729, 1494.729, 1739.887, 1739.887, 1999.413,& - 1999.413, 2270.017, 2270.017, 2548.924, 2548.924, 2833.926, 2833.926, 3123.331, 3123.331, 3415.883,& - 3415.883, 3710.664, 3710.664, 4007.015, 4007.015, 4304.469, 4304.469, 4602.695, 4602.695, 4901.459,& - 4901.459, 5200.599, 5200.599, 5500./), shape(depth_bnds)) - - do i = 1, nz - do k = 1, 42 - if (depth_bnds(1, k) <= z(i) .and. z(i) < depth_bnds(2, k)) then - z2k(i) = k - exit - end if - end do - end do - end function z2k - - - subroutine superobs_dump(tag, id, ids, n) - use nfw_mod - - character(*) :: tag - integer, intent(in) :: id - integer, intent(in) :: ids(n) - integer, intent(in) :: n - - character(STRLEN) :: fname - character(64) :: dname - character(64) :: vname - integer :: ncid, did(1), vid - - if (id > NF_MAX_DIMS) then - return - end if - - write(fname, '(a, a, a)') 'superobs-', trim(tag), '.nc' - if (id == 1) then - print *, 'dumping obs ids for each superob to "', trim(fname), '"' - call nfw_create(fname, nf_clobber, ncid) - else - call nfw_open(fname, nf_write, ncid) - call nfw_redef(fname, ncid) - end if - - write(dname, '(a,i0)') 'd', id - call nfw_def_dim(fname, ncid, trim(dname), n, did(1)) - write(vname, '(a,i0)') 'v', id - call nfw_def_var(fname, ncid, trim(vname), nf_int, 1, did(1), vid) - call nfw_enddef(fname, ncid) - - call nfw_put_var_int(fname, ncid, vid, ids) - - call nfw_close(fname, ncid) - end subroutine superobs_dump - -end module m_superobs diff --git a/assim/enkf_cf-system2_old/prep_obs/m_write_wet_file.F90 b/assim/enkf_cf-system2_old/prep_obs/m_write_wet_file.F90 deleted file mode 100755 index 6750029c..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/m_write_wet_file.F90 +++ /dev/null @@ -1,37 +0,0 @@ -module m_write_wet_file - -contains - - subroutine write_wet_file(obs, nrobs) - use mod_measurement - implicit none - - type (measurement), intent(inout) :: obs(:) - - integer, intent(in):: nrobs - integer j, i, nrshow - logical ex - - nrshow = max(nrobs / 10, 1) - print *, '10 observations:' - print '(a)',' # obs var id lon lat depth ipiv jpiv nsup'//& - ' 4-bilin-coeffs active orig (i,j) N age orig_id' - inquire(iolength = i) obs(1) - open (11, file = 'observations.uf', status = 'replace',& - form = 'unformatted', access = 'direct', recl = i) - - do j = 1, nrobs - write(11, rec = j) obs(j) - if (obs(j) % d > 1.01 .and. trim(obs(j) % id) == 'ICEC') then - print *, obs(j) % lon, obs(j) % lat, obs(j) % d, obs(j) % var - end if - if (mod(j, nrshow) == 0) then - print '(i6,2g10.2,a6,3f6.1,3i6,4f5.1,l5,2i7,f7.1,i5,i8)', j, obs(j) - end if - enddo - close(11) - print *, 'Observations printed to file observation.uf' - end subroutine write_wet_file - -end module m_write_wet_file - diff --git a/assim/enkf_cf-system2_old/prep_obs/makefile b/assim/enkf_cf-system2_old/prep_obs/makefile deleted file mode 100755 index 4f2364b6..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/makefile +++ /dev/null @@ -1,94 +0,0 @@ -MPI = YES -VPATH = ../EnKF:../EnKF/TMP:.:TMP:../shared - -include make.inc.$(MACH) - -SHELL = /bin/bash - -PROGS=prep_obs - -all: $(PROGS) - -PREP_SRC_F90 = mod_angles.F90\ -byteswapper.F90\ -spline.F90\ -qmpi.F90\ -m_confmap.F90\ -m_bilincoeff.F90\ -m_get_def_wet_point.F90\ -m_nf90_err.F90\ -m_oldtonew.F90\ -m_pivotp_micom.F90\ -m_pivotp.F90\ -m_get_micom_dim.F90\ -m_get_micom_grid.F90\ -m_get_micom_fld.F90\ -m_read_CERSAT_data.F90\ -m_read_CLS_SLA.F90\ -m_read_micom_SST.F90\ -m_read_micom_SSH.F90\ -m_read_CLS_TSLA.F90\ -m_read_MET_SST.F90\ -m_read_HadI_SST.F90\ -m_read_NOAA_SST.F90\ -m_read_CLS_SSH.F90\ -m_read_CLS_SST.F90\ -m_read_CLS_SST_grid.F90\ -m_read_MET_SST_grid.F90\ -m_read_CLS_TSLA_grid.F90\ -m_read_CLS_data.F90\ -m_read_CLS_header.F90\ -m_read_FFI_glider.F90\ -m_read_ifremer_argo.F90\ -m_read_EN4_profile.F90\ -m_read_amsr_norsex.F90\ -m_read_metno_icec.F90\ -m_superobs.F90\ -m_uobs.F90\ -m_write_wet_file.F90\ -mod_grid.F90\ -nfw.F90 - -PREP_OBS_SRC_F90 = $(PREP_SRC_F90)\ -mod_measurement.F90\ -m_spherdist.F90\ -m_parse_blkdat.F90\ -p_prep_obs.F90 - -PREP_OBS_SRC_C = superobs.c\ -superobs3d.c - -PREP_OBS_OBJ = $(PREP_OBS_SRC_C:.c=.o) $(PREP_OBS_SRC_F:.F=.o) $(PREP_OBS_SRC_F90:.F90=.o) -m_pivotp_micom.o: nfw.o m_spherdist.o -m_bilincoeff.o: m_oldtonew.o mod_grid.o -m_get_def_wet_point.o: m_pivotp_micom.o m_get_micom_dim.o m_confmap.o m_spherdist.o mod_measurement.o mod_grid.o -m_read_CERSAT_data.o: nfw.o -m_read_CLS_TSLA.o: nfw.o -p_prep_obs.o: nfw.o m_uobs.o m_get_micom_grid.o -m_uobs.o: qmpi.o - -prep_obs: $(PREP_OBS_OBJ) - @echo "->prep_obs" - @echo $(LD) $(LINKFLAGS) -o ../../../prep_obs $(PREP_OBS_OBJ) $(LIBS) - @cd ./TMP; $(LD) $(LINKFLAGS) -o ../../../prep_obs $(PREP_OBS_OBJ) $(LIBS) - -$(PREP_OBS_OBJ): makefile MODEL.CPP - -clean: - @rm -f TMP/*.f TMP/*.o TMP/*.f90 TMP/*.h TMP/*.mod $(PROGS) - -%.o: %.F90 - @echo " $*".F90 - @rm -f ./TMP/$*.f90 - @cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f90 - @cd ./TMP; $(CF90) -c $(FFLAGS) $(F90FLG) -o $*.o $*.f90 - -%.o: %.F - @echo " $*".F - @rm -f ./TMP/$*.f - @cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f - @cd ./TMP; $(CF77) -c $(FFLAGS) $(F77FLG) -o $*.o $*.f 2> /dev/null - -%.o: %.c - @echo " $*".c - @cd ./TMP ; $(CC) -c $(CFLAGS) -o $*.o -I.. -I../../EnKF ../$*.c diff --git a/assim/enkf_cf-system2_old/prep_obs/mod_angles.F90 b/assim/enkf_cf-system2_old/prep_obs/mod_angles.F90 deleted file mode 100755 index 2184d7b6..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/mod_angles.F90 +++ /dev/null @@ -1,31 +0,0 @@ -! Subprograms for the conversion of angles. -module mod_angles - -contains - - function ang360(ang) - ! Maps arbitrary angle to [0, 360) degrees. - - real ang360 - - real, intent(in) :: ang - - ang360 = mod(ang, 360.0) - (sign(1.0,ang)-1.0)*180.0 - - end function ang360 - - function ang180(ang) - ! Maps arbitrary angle to [-180, 180) degrees. - ! Use this whenever two angles are subtracted. - ! Requires ang360. - - real ang180 - - real, intent(in) :: ang - - ang180 = ang360(ang) - ang180 = ang180 - 180.0*(sign(1.0,ang180-180.0)+1.0) - - end function ang180 - -end module mod_angles diff --git a/assim/enkf_cf-system2_old/prep_obs/mod_grid.F90 b/assim/enkf_cf-system2_old/prep_obs/mod_grid.F90 deleted file mode 100755 index c59cf38e..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/mod_grid.F90 +++ /dev/null @@ -1,293 +0,0 @@ -module mod_grid -! Contains the type definition for regular (or irregular grids) together -! with a selection of subprograms for extracting information about the -! grid. -! -! 28.1.99, Oyvind.Breivik@nrsc.no. -! -! Future extensions: function checkgrid returns zero if grid contains errors -! or is not set. Include function overloading so that checkgrid may return both -! integer and real. - -!!! Module - -use mod_angles - -!!! Type definition - - ! Type grid contains information for constructing a 1D, 2D, or 3D grid. The - ! grid may be periodic and physical units may be added to keep track of - ! the physical dimensions of start points and resolution of the grid. - ! - ! Oyvind Breivik, 30.12.98. - - type grid - integer :: nx, ny, nz ! No of grid points - real :: dx, dy, dz ! Resolution - real :: x0, y0, z0 ! Start point (lower left) - real :: undef ! Undefined value, typically 999.0 - integer :: order ! 1D, 2D or 3D grid? Default is 2. - logical :: px, py, pz ! Periodic grid in x, y, z? Default is .false. - logical :: reg ! Regular grid? Default is .true. - ! If not, order should be 1, indicating an - ! array of unevenly spaced data rather than a - ! proper grid. In this case, resolution and - ! start point become meaningless. - logical :: set ! Grid initialized or containing default settings? - character(len=10) :: ux, uy, uz ! Physical units, 'deg' denotes degrees, - ! default is '1', nondimensional. - end type grid - - type (grid), parameter :: default_grid = grid(0, 0, 0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 999.0, 0, .false., .false., .false., & - .true., .false., '1', '1', '1') - -contains - -!!! Subprograms - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function gridpoints(gr) - ! Calculates the total number of grid points N in a regular grid of - ! type grid or an irregular array of type grid. Returns zero if grid is not - ! initialized. - - ! Oyvind Breivik, 30.12.98. - - !!! Interface - - integer gridpoints - - type (grid), intent (in) :: gr - - select case (gr%order) - case (1) - gridpoints = gr%nx - case (2) - gridpoints = gr%nx*gr%ny - case (3) - gridpoints = gr%nx*gr%ny*gr%nz - end select - - if (.not. gr%reg) then ! Irregular grid? - gridpoints = gr%nx - end if - - if (.not. gr%set) then ! Grid initialized or containing default values? - gridpoints = 0 ! If not initialized, return zero. - end if - - end function gridpoints - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function gridindex(x,dimid,gr) - ! Finds corresponding grid index for coordinate x for grid dimension dimid, - ! where dimid = 1 denotes x, dimid = 2 - ! denotes y, and dimid = 3 denotes z. If dimid < 0, the grid index is - ! rounded down using INT, so that the corresponding grid point is ``to - ! the left'' of x. Otherwise NINT is used and the nearest grid point is - ! found. - ! - ! A return value of zero indicates that x is out of range or grid not - ! initialized. - ! Note that (x-x0) is mapped to [-180, 180] degrees if and only if the - ! variable ux, uy, or uz (depending again on dimid) equals 'deg'. This is - ! to ensure that crossing the zero longitude branch cut is handled correctly. - ! A return value of -1 indicates that dimid is illegal (greater than the - ! order of the grid). - ! - ! Requires module mod_angles. - - !!! Interface - - integer gridindex - - real, intent (in) :: x - integer, intent (in) :: dimid - type (grid), intent (in) :: gr - - !!! Locals - - real :: x0, x1, dx, e - integer :: nx - logical :: closest, deg - - !!! Initialize - - closest = (dimid > 0) - - select case (abs(dimid)) ! Choose correct grid dimension - case (1) - x0 = gr%x0 - dx = gr%dx - nx = gr%nx - deg = (gr%ux == 'deg') - case (2) - x0 = gr%y0 - dx = gr%dy - nx = gr%ny - deg = (gr%uy == 'deg') - case (3) - x0 = gr%z0 - dx = gr%dz - nx = gr%nz - deg = (gr%uz == 'deg') - end select - - x1 = x - x0 - - if (closest) then - e = dx/2 ! Small value epsilon - else - e = 0.0 - end if - - if (deg) then - x1 = ang360(x1+e) ! Adding dx/2 is a trick to avoid the branch cut - x1 = x1-e ! when finding the closest grid point. - end if - - if (.not. closest) then - x1 = x1 - dx/2 ! Round down - end if - - gridindex = nint(x1/dx) + 1 - - if (gridindex < 1 .or. gridindex > nx) then - gridindex = 0 - end if - - if (abs(dimid) > gr%order) then - gridindex = -1 - end if - - if (.not. gr%set) then - gridindex = 0 - end if - - end function gridindex - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function gridpos(i,dimid,gr) - ! Returns the position of grid node i along dimension dimid in grid. - ! - ! If dimid < 0 and the physical unit of the grid is degrees, - ! -180 <= gridpos < 180 [deg]. Otherwise, 0 <= gridpos < 360 [deg]. - ! - ! Requires module mod_angles. - - !!! Interface - - real gridpos - - integer, intent (in) :: i, dimid - type (grid), intent (in) :: gr - - !!! Locals - - real x0, dx - logical deg - - select case (abs(dimid)) - case (1) - x0 = gr%x0 - dx = gr%dx - deg = (gr%ux == 'deg') - case (2) - x0 = gr%y0 - dx = gr%dy - deg = (gr%uy == 'deg') - case (3) - x0 = gr%z0 - dx = gr%dz - deg = (gr%uz == 'deg') - end select - - gridpos = x0 + real(i-1)*dx - - if (deg) then - if (dimid < 0) then - gridpos = ang180(gridpos) - else - gridpos = ang360(gridpos) - end if - end if - - end function gridpos - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function ingrid(x,dimid,gr) - ! Is x within [x0, x1]? Here x0 and x1 denote the physical - ! bounds of the grid along dimension dimid. If dimid < 0 then ingrid - ! checks the interval [-dx/2+x0, x1+dx/2] instead. - ! - ! Requires module mod_angles. - - !!! Interface - - logical ingrid - - real, intent (in) :: x - integer, intent (in) :: dimid - type (grid), intent (in) :: gr - - !!! Locals - - real x0, x1, dx - integer nx - logical deg - - select case (abs(dimid)) - case (1) - dx = gr%dx - x0 = gr%x0 - nx = gr%nx - deg = (gr%ux == 'deg') - case (2) - dx = gr%dy - x0 = gr%y0 - nx = gr%ny - deg = (gr%uy == 'deg') - case (3) - dx = gr%dz - x0 = gr%z0 - nx = gr%nz - deg = (gr%uz == 'deg') - end select - - x1 = gridpos(nx,dimid,gr) - - if (dimid < 0) then - x0 = x0 - dx/2 - x1 = x1 + dx/2 - end if - - ingrid = (x0 <= x) .and. (x <= x1) - - if (deg) then - ingrid = ang360(x1-x0) >= ang360(x-x0) - end if - - ingrid = ingrid .and. gr%set - - end function ingrid - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function undefined(d,gr) - ! True if d == gr%undef. - - logical undefined - - real, intent (in) :: d - type (grid), intent (in) :: gr - - undefined = abs(d-gr%undef) < 0.01 - - end function undefined - - - -end module mod_grid diff --git a/assim/enkf_cf-system2_old/prep_obs/p_prep_obs.F90 b/assim/enkf_cf-system2_old/prep_obs/p_prep_obs.F90 deleted file mode 100755 index 62dfb7dd..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/p_prep_obs.F90 +++ /dev/null @@ -1,502 +0,0 @@ -! File : p_prep_obs.F90 -! -! Created: unknown -! -! Author: unknown -! -! Purpose: Read data from different data sources and convert it to -! type(measurement). -! -! Description: The code calls different subroutines for particular types of -! input data, depending on the source, observation type and -! format. The output is the array of type(measurement) that -! contains, in particular, pivot points and bilinear -! interpolation coefficients for each observation. This array -! is written to "observations.uf" in binary format. -! -! Modifications: 30/01/2008 - Pavel Sakov gave a trim (formatted) -- sorry -! for that, could not stand -- and modified to allow in-situ -! argo data from ifremer. -! 02/09/2008 - Pavel Sakov added superobing for SST and SLA data -! 17/08/2010 PS - turned (3D) superobing on for Argo obs -! 02/03/2016 Yiguo WANG: available for EN4 dataset -! 04/08/2016 Yiguo WANG modified m_read_CLS_SSH -! -program p_prep_obs - use mod_measurement - use mod_grid - use m_read_micom_SST - use m_read_micom_SSH - use m_read_CLS_header - use m_read_CLS_data - use m_read_CLS_SST_grid - use m_read_MET_SST_grid - use m_read_CLS_TSLA_grid - use m_read_CLS_SST - use m_read_CLS_SSH - use m_read_CLS_SLA - use m_read_CLS_TSLA - use m_read_MET_SST - use m_read_HadI_SST - use m_read_NOAA_SST - use m_read_CERSAT_data - use m_read_ifremer_argo - use m_read_EN4_profile - use m_read_FFI_glider - use m_read_metno_icec - use m_get_def_wet_point - use m_write_wet_file - use m_get_micom_grid - use m_parse_blkdat - use m_read_amsr_norsex - use m_superobs - use m_uobs - use m_get_micom_dim - implicit none - - integer, parameter :: STRLEN = 512 - - type (measurement), allocatable :: data(:) - type (measurement), allocatable :: obs(:) - type (grid) :: gr - - integer :: nx, ny, nz - real, allocatable, dimension(:,:) :: depths, modlat, modlon,mask - integer, parameter :: maxobs = 5000000 - character(STRLEN) :: fname, fnamehdr, dataformat, producer - character(len=3) :: form - character(len=5) :: obstype - - integer :: nrobs - integer :: grpoints, k - real :: factor, var - real :: rdummy, mindx, meandx - - logical :: data_eq_obs - - ! superobs - logical :: dosuperob - logical :: is3d - integer :: nrsobs - type(measurement), allocatable :: sobs(:) - - integer :: i - integer :: nthisobs - integer, allocatable, dimension(:) :: thisobs - - gr = default_grid - data_eq_obs = .false. - - open(10, file = 'infile.data') - read(10, '(a)') producer - read(10, '(a)') obstype - read(10, '(a)') fnamehdr - read(10, '(a)') fname - close(10) - - print *, 'Data producer: ', trim(producer) - print *, 'Data to be processed for NorCPM: ', trim(obstype) - print *, 'Observational error variance: ', trim(fnamehdr) - print *, 'Filenames to be processed: ', trim(fname) - print *, 'Result of processing is stored in temporary file "observation.uf"' - - ! Get grid dimensions - call get_micom_dim(nx,ny,nz) - ! - allocate(depths(nx, ny)) - allocate(mask(nx, ny)) - allocate(modlon(nx, ny)) - allocate(modlat(nx, ny)) - ! Read position and depth from model grid - ! - call get_micom_grid(modlon, modlat, depths, mindx, meandx, nx, ny) - - dosuperob = .false. - is3d = .false. - - ! Fill the "data" array by calling subroutines specific for the producer - ! and observation type - ! - if (trim(producer) == 'Reynolds') then - - if (trim(obstype) == 'SST') then - dosuperob = .true. - call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var) - !grpoints = gr % nx * gr % ny - grpoints = 64980 - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CLS_data(fname, obstype, dataformat, gr, form, data, factor, var) - print*, 'Reynolds- ', obstype, ' data has been scaled by a factor = ', factor - else - stop 'ERROR: Reynolds only produce SST' - endif - - else if (trim(Producer) == 'MET') then - - if (trim(obstype) == 'SST') then - dosuperob = .true. - call read_MET_SST_grid(fnamehdr, gr) - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_MET_SST(fname, gr, data) - else - stop 'ERROR: OSTIA (MET) only produces SST' - endif - else if (trim(Producer) == 'Had') then - if (trim(obstype) == 'SST') then - dosuperob = .false. - !data has 1 degree resolution (300*180) - !could have read it from the file but hardcoded from now - gr%reg = .true. - gr%order = 2 - gr%nx=360 - gr%ny=180 - gr%set=.true. - grpoints = gr%nx*gr%ny - allocate(data(grpoints)) - print * ,'Reading HadI SST data' - call read_HadI_SST(fname,fnamehdr,data,modlon, modlat, depths,360,180, nrobs) - allocate(obs(nrobs)) - data_eq_obs = .false. - print *,'HadI Data read',nrobs - else - stop 'ERROR: (HadI) only produces SST' - endif - else if (trim(Producer) == 'NOAA') then - if (trim(obstype) == 'SST') then - !dosuperob = .true. - dosuperob = .false. - !data has 1 degree resolution (300*180) - !could have read it from the file but hardcoded from now - gr%reg = .true. - gr%order = 2 - gr%nx=360 - gr%ny=180 - gr%set=.true. - grpoints = gr%nx*gr%ny - allocate(data(grpoints)) - print * ,'Reading NOAA SST data' - call read_NOAA_SST(fname,fnamehdr,data,modlon, modlat, depths,360,180, nrobs) - allocate(obs(nrobs)) - data_eq_obs = .false. - print *,'NOAA Data read',nrobs - else - stop 'ERROR: (NOAA) only produces SST' - endif - else if (trim(Producer) == 'micom') then - if (trim(obstype) == 'SST') then - dosuperob = .false. - mask(:,:)=0 - where(depths>0)mask=1; - grpoints = sum(mask) - print *,'Number of wet point',grpoints - allocate(data(grpoints)) - !fnamehdr contains the month and fname the year file - call read_micom_SST(fname,fnamehdr,data,modlon, modlat, depths, nx, ny, nrobs) - data_eq_obs = .true. - print *,'Data read' - elseif (trim(obstype) == 'SSH') then - dosuperob = .false. - mask(:,:)=0 - where(depths>0)mask=1; - grpoints = sum(mask) - print *,'Number of wet point',grpoints - allocate(data(grpoints)) - !fnamehdr contains the month and fname the year file - call read_micom_SSH(fname,fnamehdr,data,modlon, modlat, depths, nx, ny) - data_eq_obs = .true. - print *,'Data read' - else - stop 'ERROR: micom only produces SST' - endif - else if (trim(Producer) == 'NSIDC-AMSR') then - - if (trim(obstype) == 'ICEC') then - dosuperob = .true. - call read_amsr_norsex(fname, gr, data, obstype) - allocate (obs(maxobs)) - else - print *, 'No ',obstype, ' data from:', Producer - stop 'ERROR: p_prep_obs' - endif - - else if (trim(Producer) == 'METNO') then - - if (trim(obstype) == 'ICEC') then - dosuperob = .true. - call read_metno_icec(fname, data, gr) - allocate (obs(size(data))) - else - print *, 'There can be no ', obstype,' data from', Producer - stop - endif - - elseif (trim(producer) == 'CLS') then - - if (trim(obstype) == 'SLA') then - dosuperob = .true. - ! call read_CLS_SST_grid() here because SST data grid has the same - ! structure - call read_CLS_SST_grid(fnamehdr, gr) - grpoints = gr % nx * gr % ny - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CLS_SLA(fname, gr, data) - - elseif (trim(obstype) == 'SSH') then - dosuperob = .false. - !data has 1 degree resolution (360*180) - !could have read it from the file but hardcoded from now - gr%reg = .true. - gr%order = 2 - gr%nx=360 - gr%ny=180 - gr%set=.true. - grpoints = gr%nx*gr%ny - allocate(data(grpoints)) - print * ,'Reading CLS SSH data' - call read_CLS_SSH(fname, data, modlon, modlat, depths, gr%nx, gr%ny, nrobs, nx, ny) - data_eq_obs = .true. - print *,'CLS Data read', nrobs - - elseif (trim(obstype) == 'SST') then - dosuperob = .true. - call read_CLS_SST_grid(fnamehdr, gr) - grpoints = gr % nx * gr % ny - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CLS_SST(fname, gr, data) - - elseif (trim(obstype) == 'TSLA') then - dosuperob = .true. - call read_CLS_TSLA_grid(fnamehdr, gr) - print *, 'read_CLS_TSLA_grid finished, total # of obs = ', gr % nx - grpoints = gr % nx - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CLS_TSLA(fname,gr,data) - else - print *, 'data of type "', trim(obstype),'" from producer "', producer, '" is not handled' - stop 'ERROR: p_prep_obs' - endif - - else if (trim(producer) == 'NSIDC') then - if (trim(obstype) == 'ICEC') then - dosuperob = .true. - call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var) - grpoints = gr % nx * gr % ny - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CLS_data(fname, obstype, dataformat, gr, form, data, factor, var) - print *, producer, obstype, 'data has been scaled by a factor = ', factor - else - print *, 'no data of type "', trim(obstype),'" from producer "', producer, '" is not handled' - stop 'ERROR: p_prep_obs' - endif - - else if (trim(producer) == 'CERSAT') then - if (trim(obstype) == 'idrft') then - dosuperob = .false. - call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var) - grpoints = gr % nx ! NB - 2 vector components - irregular grid - allocate(data(grpoints)) - allocate(obs(maxobs)) - call read_CERSAT_data(trim(fname), gr, data, grpoints, var) - print *, producer, obstype, 'data has been scaled by a factor = ', factor - else - print *, 'no data of type "', trim(obstype),'" from producer "', producer, '" is not handled' - stop 'ERROR: p_prep_obs' - endif - - elseif (trim(producer) == 'IFREMER') then - - dosuperob = .true. - is3d = .true. - read(fnamehdr, *) var - print *, 'variance =', var - call read_ifremer_argo(fname, obstype, var, nx, ny, data) - - ! PS: This is a flag to denote that read_ifremer_argo() takes care of - ! filling type(measurement) array "data" in a correct way, and it should - ! not be re-processed by calling get_def_wet_point(). This may not match - ! the ideology behind the workflow adopted in this module and may be - ! changed in future. - ! - data_eq_obs = .true. - - elseif (trim(producer) == 'FFI') then - - dosuperob = .true. - is3d = .true. - read(fnamehdr, *) var - print *, 'variance =', var - call read_FFI_glider(fname, obstype, var, nx, ny, data) - data_eq_obs = .true. - - elseif (trim(producer) == 'EN4') then - - dosuperob = .true. - is3d = .true. - read(fnamehdr, *) var - call read_EN4_profile(fname, obstype, var, nx, ny, data, nrobs) - - data_eq_obs = .true. - else - print *, 'unknown producer ', trim(producer), ' in "infile.data"' - stop 'ERROR: p_prep_obs' - endif - - - if (.not. data_eq_obs) then - ! Compute bilinear coefficients - ! Extract the defined and wet data points - ! Write locations to ijfile to be used in TECPLOT - ! - call get_def_wet_point(obs, data, gr, depths, modlat, modlon, nrobs, nx, ny) - else - allocate(obs(nrobs)) - obs(:nrobs) = data - - print *,'Nb of data dumped is :',nrobs - end if - deallocate(data) - - print *,'Updated age ',minval(obs(:)%date),maxval(obs(:)%date) - if (trim(obstype) == 'TSLA') then - call set_re_TSLA(nrobs, obs, nx, ny, modlon, modlat) - end if - - where (obs % d + 1.0 == obs % d) - obs % status = .false. - end where - - ! Superob dense data - ! - if (dosuperob) then - allocate(sobs(nrobs)) - print *,'Min age/max age',minval(obs(1:nrobs)%date),maxval(obs(1:nrobs)%date) - call superob(obstype, nrobs, obs, nx, ny, modlon, modlat, nrsobs, sobs, is3d) - - deallocate(obs) - allocate(obs(nrsobs)) - obs = sobs(1 : nrsobs) - nrobs = nrsobs - deallocate(sobs) - end if - - if (nrobs .ge. maxobs) then - print *, 'max No. of data reached, increase it!' - stop 'ERROR: p_prep_obs' - elseif (nrobs .le. 1) then - print *, 'less than one observation in the whole dataset' - !PS 4/9/2011 stop 'ERROR: p_prep_obs: Not worth the money' - end if - - ! Write data to the binary file "observations.uf" - ! - call write_wet_file(obs, nrobs) - - call uobs_get(obs(1 : nrobs) % id, nrobs, .true.) - allocate(thisobs(nrobs)) - do i = 1, nuobs - nthisobs = 0 - do k = 1, nrobs - if (trim(unique_obs(i)) == trim(obs(k) % id)) then - nthisobs = nthisobs + 1 - thisobs(nthisobs) = k - end if - end do - - if (nthisobs > 0) then - call obs2nc(nthisobs, obs(thisobs(1 : nthisobs))) - end if - end do - deallocate(thisobs) - - print *, 'Last observation:' - print '(a)',' obs var id lon lat depth ipiv jpiv nsup'//& - ' 4-bilin-coeffs active orig (i,j) dp age orig_id' - print '(2g10.2,a6,3f6.1,3i6,4f5.1,l5,2i7,f7.1,2i5)', obs(nrobs) - - deallocate(obs) - deallocate(depths) - deallocate(modlon) - deallocate(modlat) - - print *, 'prep_obs: end of processing' -end program p_prep_obs - - -subroutine obs2nc(nobs, obs) - use mod_measurement - use nfw_mod - implicit none - - integer, parameter :: STRLEN = 512 - - integer, intent(in) :: nobs - type(measurement), intent(in) :: obs(nobs) - - character(STRLEN) :: fname - integer :: ncid, obsdimid(1), lon_id, lat_id, depth_id, d_id, var_id, age_id - integer :: n_id, ipiv_id, jpiv_id - integer :: n(nobs) - - ! Create netcdf file of observations - ! - write(fname, '(a, a, a)') 'observations-', trim(obs(1) % id), '.nc' - print *, 'dumping observations to "', trim(fname), '"' - - call nfw_create(fname, nf_clobber, ncid) - - call nfw_def_dim(fname, ncid, 'nobs', nobs, obsdimid(1)) - call nfw_def_var(fname, ncid, 'lon', nf_float, 1, obsdimid(1), lon_id) - call nfw_def_var(fname, ncid, 'lat', nf_float, 1, obsdimid(1), lat_id) - call nfw_def_var(fname, ncid, 'depth', nf_float, 1, obsdimid(1), depth_id) - call nfw_def_var(fname, ncid, 'd', nf_float, 1, obsdimid(1), d_id) - call nfw_def_var(fname, ncid, 'var', nf_float, 1, obsdimid(1), var_id) - call nfw_def_var(fname, ncid, 'age', nf_int, 1, obsdimid(1), age_id) - call nfw_def_var(fname, ncid, 'n', nf_int, 1, obsdimid(1), n_id) - call nfw_def_var(fname, ncid, 'ipiv', nf_int, 1, obsdimid(1), ipiv_id) - call nfw_def_var(fname, ncid, 'jpiv', nf_int, 1, obsdimid(1), jpiv_id) - call nfw_enddef(fname, ncid) - - call nfw_put_var_double(fname, ncid, lon_id, obs(1:nobs) % lon) - call nfw_put_var_double(fname, ncid, lat_id, obs(1:nobs) % lat) - call nfw_put_var_double(fname, ncid, depth_id, obs(1:nobs) % depth) - call nfw_put_var_double(fname, ncid, d_id, obs(1:nobs) % d) - call nfw_put_var_double(fname, ncid, var_id, obs(1:nobs) % var) - call nfw_put_var_int(fname, ncid, age_id, obs(1:nobs) % date) - call nfw_put_var_int(fname, ncid, ipiv_id, obs(1:nobs) % ipiv) - call nfw_put_var_int(fname, ncid, jpiv_id, obs(1:nobs) % jpiv) - n = int(obs(1:nobs) % h) - call nfw_put_var_int(fname, ncid, n_id, n) - - call nfw_close(fname, ncid) -end subroutine obs2nc - - -subroutine check_forland(data, depths, nrobs, ni, nj) - use mod_measurement - - type (measurement), intent(inout), dimension(nrobs) :: data - real, dimension(ni, nj), intent(in) :: depths - integer, intent(in) :: nrobs - integer, intent(in) :: ni, nj - - integer :: o, imin, jmin, imax, jmax, nmasked - - nmasked = 0 - do o = 1, nrobs - imin = max(1, data(o) % ipiv - 1) - jmin = max(1, data(o) % jpiv - 1) - imax = min(ni, data(o) % ipiv + 2) - jmax = min(nj, data(o) % jpiv + 2) - if (any(depths(imin:imax,jmin:jmax) < 10.0 .or. depths(imin:imax,jmin:jmax) == depths(imin:imax,jmin:jmax) + 1.0)) then - data(o) % status = .false. - nmasked = nmasked + 1 - end if - end do - print *, " check_forland(): ", nmasked, "obs close to land masked" -end subroutine check_forland diff --git a/assim/enkf_cf-system2_old/prep_obs/superobs.c b/assim/enkf_cf-system2_old/prep_obs/superobs.c deleted file mode 100755 index be6b2686..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/superobs.c +++ /dev/null @@ -1,73 +0,0 @@ -/* File: superobs.c - * - * Created: 2 Sep 2008 - * - * Last modified: 2 Sep 2008 - * Author: Pavel Sakov - * NERSC - * - * Purpose: Sorting of observations according to model grid cells. - * - * Description: Given array of pivot indices for each observation, sort them - * in such a way that observations within each model grid cell - * will cluster together. - * - * Modifications: none - */ - -#include -#include "cfortran.h" - -#define IMAX 4096 -#define JMAX 4096 - -typedef struct { - int i; - int j; - int index; -} indexedvalue; - -static int comp(const void* p1, const void* p2) -{ - indexedvalue* v1 = (indexedvalue*) p1; - indexedvalue* v2 = (indexedvalue*) p2; - - if (v1->i > v2->i) - return 1; - else if (v1->i < v2->i) - return -1; - else if (v1->j > v2->j) - return 1; - else if (v1->j < v2->j) - return -1; - return 0; -} - -void sortgriddedobs(double pn, int ipiv[], int jpiv[], int sorted[]) -{ - int n = (int) pn; - indexedvalue* iv = malloc(n * sizeof(indexedvalue)); - int i; - - for (i = 0; i < n; ++i) { - int ii = ipiv[i]; - int jj = jpiv[i]; - - if (ii <= 0 || ii > IMAX || jj <= 0 || jj > JMAX) { - fprintf(stderr, "ERROR: superobs.c: sortgriddedobs(): ipiv(%d) = %d or jpiv(%d) = %d out of bounds\n", i, ii, i, jj); - exit(1); - } - iv[i].i = ii; - iv[i].j = jj; - iv[i].index = i; - } - - qsort(iv, n, sizeof(indexedvalue), comp); - - for (i = 0; i < n; ++i) - sorted[i] = iv[i].index + 1; - - free(iv); -} - -FCALLSCSUB4(sortgriddedobs, SORTGRIDDEDOBS, sortgriddedobs, DOUBLE, PINT, PINT, PINT) diff --git a/assim/enkf_cf-system2_old/prep_obs/superobs3d.c b/assim/enkf_cf-system2_old/prep_obs/superobs3d.c deleted file mode 100755 index 47ad60fc..00000000 --- a/assim/enkf_cf-system2_old/prep_obs/superobs3d.c +++ /dev/null @@ -1,79 +0,0 @@ -/* File: superobs3.c - * - * Created: 17 Nov 2009 - * - * Last modified: 17 Nov 2009 - * Author: Pavel Sakov - * NERSC - * - * Purpose: Sorting of observations according to model grid cells. - * - * Description: This file is an extension of the superobs.c for the 3D case. - * - * Modifications: 02 Mar 2016: Yiguo WANG modified KMAX from 150 to 10000 - */ - -#include -#include "cfortran.h" - -#define IMAX 4096 -#define JMAX 4096 -#define KMAX 10000 - -typedef struct { - int i; - int j; - int k; - int index; -} indexedvalue; - -static int comp(const void* p1, const void* p2) -{ - indexedvalue* v1 = (indexedvalue*) p1; - indexedvalue* v2 = (indexedvalue*) p2; - - if (v1->i > v2->i) - return 1; - else if (v1->i < v2->i) - return -1; - else if (v1->j > v2->j) - return 1; - else if (v1->j < v2->j) - return -1; - else if (v1->k > v2->k) - return 1; - else if (v1->k < v2->k) - return -1; - return 0; -} - -void sortgriddedobs3d(double pn, int ipiv[], int jpiv[], int kpiv[], int sorted[]) -{ - int n = (int) pn; - indexedvalue* iv = malloc(n * sizeof(indexedvalue)); - int i; - - for (i = 0; i < n; ++i) { - int ii = ipiv[i]; - int jj = jpiv[i]; - int kk = kpiv[i]; - - if (ii <= 0 || ii > IMAX || jj <= 0 || jj > JMAX || kk < 0 || kk > KMAX) { - fprintf(stderr, "ERROR: superobs3d.c: sortgriddedobs(): ipiv(%d) = %d or jpiv(%d) = %d or kpiv(%d) = %d out of bounds\n", i, ii, i, jj, i, kk); - exit(1); - } - iv[i].i = ii; - iv[i].j = jj; - iv[i].k = kk; - iv[i].index = i; - } - - qsort(iv, n, sizeof(indexedvalue), comp); - - for (i = 0; i < n; ++i) - sorted[i] = iv[i].index + 1; - - free(iv); -} - -FCALLSCSUB5(sortgriddedobs3d, SORTGRIDDEDOBS3D, sortgriddedobs3d, DOUBLE, PINT, PINT, PINT, PINT) diff --git a/assim/enkf_cf-system2_old/shared b/assim/enkf_cf-system2_old/shared deleted file mode 120000 index dd81f52b..00000000 --- a/assim/enkf_cf-system2_old/shared +++ /dev/null @@ -1 +0,0 @@ -../enkf_cmip6_i1/shared \ No newline at end of file diff --git a/assim/enkf_noresm2_oda/EnKF/EnKF.F90 b/assim/enkf_noresm2_oda/EnKF/EnKF.F90 index 9ea3e586..d75462b0 100755 --- a/assim/enkf_noresm2_oda/EnKF/EnKF.F90 +++ b/assim/enkf_noresm2_oda/EnKF/EnKF.F90 @@ -256,11 +256,10 @@ program EnKF do m = m1, m2 !29/05/2015 fanf add 3 digit to qmpi -! print '(a, i2, a, i3, a, a6, a, i3, a, f11.0)',& -! print '(a, i3, a, i3, a, a6, a, i3, a, f11.0)',& -! "I am ", qmpi_proc_num, ', m = ', m, ", field = ",& -! fieldnames(m), ", k = ", fieldlevel(m), ", time = ",& -! rtc() - time2 + print '(a, i3, a, i3, a, a6, a, i3, a, f11.0)',& + "I am ", qmpi_proc_num, ', m = ', m, ", field = ",& + fieldnames(m), ", k = ", fieldlevel(m), ", time = ",& + rtc() - time2 if ( trim(fieldnames(m)) /= 'dp' ) then if (fieldlevel(m)>=3) then allocate(dpfld(idm * jdm, ENSSIZE)) diff --git a/assim/enkf_noresm2_oda/assim_step.sh b/assim/enkf_noresm2_oda/assim_step.sh index 684a84f7..03937ef1 100755 --- a/assim/enkf_noresm2_oda/assim_step.sh +++ b/assim/enkf_noresm2_oda/assim_step.sh @@ -4,7 +4,12 @@ . $SETUPROOT/settings/setmach.sh cd $ANALYSISROOT rm -f *_PAUSE_* -touch BLOM_DA +if [[ `echo $FREQUENCYLIST | grep DAY` ]] +then + touch BLOM_DA_DAILY +else + touch BLOM_DA_MONTHLY +fi ODA () { set -xv diff --git a/setup/noresm2/settings/noresm2-lmesm_assim_19750101.sh b/setup/noresm2/settings/noresm2-lmesm_assim_19750101.sh new file mode 100755 index 00000000..84d7dd59 --- /dev/null +++ b/setup/noresm2/settings/noresm2-lmesm_assim_19750101.sh @@ -0,0 +1,47 @@ +# EXPERIMENT DEFAULT SETTINGS +# USE VARNAME=VALUE ARGUMENT WHEN CALLING SCRIPT TO OVERRIDE DEFAULTS + +# experiment settings +: ${EXPERIMENT:=noresm2-lmesm_assim} # case prefix, not including _YYYYMMDD_memXX suffix +: ${MEMBER1:=1} # first member +: ${ENSSIZE:=10} # number of members +: ${COMPSET:=NHISTfrc2esm} +: ${USER_MODS_DIR:=$SETUPROOT/user_mods/noresm2-lmesm_128pes} +: ${RES:=f19_tn14} +: ${START_DATE:=1975-01-01} # YYYY-MM-DD + +# initialisation settings +: ${RUN_TYPE:=hybrid} +: ${REF_CASE_LIST:='NHIST_f19_tn14_20191104esm NHIST_1901_f19_tn14_20230201esm NHIST_1951_f19_tn14_20230201esm NHIST_2001_f19_tn14_20230201esm NHIST_2201_f19_tn14_20230201esm NHIST_2231_f19_tn14_20230201esm NHIST_2251_f19_tn14_20230201esm NHIST_2291_f19_tn14_20230201esm NHIST_2311_f19_tn14_20230201esm'} # full name of reference cases +: ${REF_PATH_LOCAL:=/cluster/work/users/$USER/restarts} +: ${REF_DATE:=$START_DATE} +: ${ADD_PERTURBATION:=1} # only for RUN_TYPE=hybrid + +# job settings +: ${STOP_OPTION:=nmonths} # units for run length specification STOP_N +: ${STOP_N:=1} # run continuesly for this length +: ${RESTART:=0} # restart this many times +: ${WALLTIME:='00:59:00'} +: ${ACCOUNT:=nn9039k} +: ${MAX_PARALLEL_STARCHIVE:=30} + +# general settings +: ${CASESROOT:=$SETUPROOT/../../cases} +: ${NORESMROOT:=$SETUPROOT/../../model/noresm2} +: ${ASK_BEFORE_REMOVE:=0} # 1=will ask before removing existing cases +: ${VERBOSE:=1} # set -vx option in all scripts +: ${SKIP_CASE1:=0} # skip creating first/template case, assume it exists already +: ${SDATE_PREFIX:=} # recommended are either empty or "s" +: ${MEMBER_PREFIX:=mem} # recommended are either empty or "mem" + +# assimilation settings +: ${ASSIMROOT:=$SETUPROOT/../../assim/enkf_noresm2_oda} +: ${MEAN_MOD_DIR:=$INPUTDATA_ASSIM/enkf/$RES/NorESM2-LM-CMIP6} +: ${NTASKS_DA:=128} +: ${NTASKS_ENKF:=108} +: ${OCNGRIDFILE:=$INPUTDATA/ocn/blom/grid/grid_tnx1v4_20170622.nc} +: ${OBSLIST:='TEM SAL SST'} +: ${PRODUCERLIST:='EN422 EN422 HADISST2'} +: ${FREQUENCYLIST:='MONTH MONTH MONTH'} +: ${REF_PERIODLIST:='1980-2010 1980-2010 1980-2010'} +: ${COMBINE_ASSIM:='0 0 1'} diff --git a/setup/noresm2/user_mods/noresm2-lm_128pes/SourceMods/src.blom/mod_oda.F b/setup/noresm2/user_mods/noresm2-lm_128pes/SourceMods/src.blom/mod_oda.F index 9d82fe8d..917b1eda 100644 --- a/setup/noresm2/user_mods/noresm2-lm_128pes/SourceMods/src.blom/mod_oda.F +++ b/setup/noresm2/user_mods/noresm2-lm_128pes/SourceMods/src.blom/mod_oda.F @@ -15,9 +15,18 @@ subroutine oda() c implicit none c - logical :: ldooda,lpause + logical :: ldooda,ldooda_daily,ldooda_monthly,lpause if (mod(nstep+nint(0.5*nstep_in_day),nstep_in_day).ne.0) return - inquire(file='../../ANALYSIS/BLOM_DA',exist=ldooda) + inquire(file='../../ANALYSIS/BLOM_DA_DAILY',exist=ldooda_daily) + inquire(file='../../ANALYSIS/BLOM_DA_MONTHLY', + . exist=ldooda_monthly) + if (ldooda_daily) then + ldooda = .true. + else if (ldooda_monthly .and. date%day .eq. 15) then + ldooda = .true. + else + ldooda = .false. + end if if (ldooda) then if (mnproc.eq.1) then write (lp,*) 'Perform ODA ', date%year, date%month, date%day @@ -41,7 +50,7 @@ subroutine oda() end if call restart_rd_oda else - write (lp,*) 'Skip ODA' + write (lp,*) 'Skip ODA ', date%year, date%month, date%day endif c end subroutine oda diff --git a/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/blom_step.F b/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/blom_step.F new file mode 100644 index 00000000..5686161d --- /dev/null +++ b/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/blom_step.F @@ -0,0 +1,380 @@ +#define ODA +! ------------------------------------------------------------------------------ +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak +! +! This file is part of BLOM. +! +! BLOM is free software: you can redistribute it and/or modify it under the +! terms of the GNU Lesser General Public License as published by the Free +! Software Foundation, either version 3 of the License, or (at your option) +! any later version. +! +! BLOM is distributed in the hope that it will be useful, but WITHOUT ANY +! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +! FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for +! more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with BLOM. If not, see . +! ------------------------------------------------------------------------------ + + subroutine blom_step +c +c --- ------------------------------------------------------------------ +c --- integrate a model time step +c --- ------------------------------------------------------------------ +c + use mod_config, only: expcnf + use mod_time, only: date, nday_of_year, nstep1, + . nstep, nstep_in_day, delt1, step_time + use mod_timing, only: total_time, total_xio_time, + . auxil_total_time, getfrc_total_time, + . tmsmt1_total_time, advdif_total_time, + . sfcstr_total_time, momtum_total_time, + . pgforc_total_time, barotp_total_time, + . pbcor2_total_time, convec_total_time, + . diapfl_total_time, thermf_total_time, + . mxlayr_total_time, tmsmt2_total_time, + . diaacc_total_time, io_total_time, + . get_time + use mod_xc, only: lp, mnproc, xctilr, xcsum + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, cntiso_hybrid_regrid_remap, + . remap_velocity + use mod_vdiff, only: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm + use mod_swabs, only: updswa + use mod_tmsmt, only: tmsmt1, tmsmt2 + use mod_eddtra, only: eddtra + use mod_advect, only: advect + use mod_pbcor, only: pbcor1, pbcor2 + use mod_pgforc, only: pgforc + use mod_momtum, only: momtum + use mod_mxlayr, only: mxlayr + use mod_barotp, only: barotp + use mod_cmnfld_routines, only: cmnfld_bfsqi_cntiso_hybrid, + . cmnfld1, cmnfld2 + use mod_forcing, only: fwbbal + use mod_budget, only: budget_sums, budget_output + use mod_eddtra, only: eddtra + use mod_momtum, only: momtum + use mod_difest, only: difest_isobml, difest_lateral_hybrid, + . difest_vertical_hybrid + use mod_chkvar, only: chkvar + use mod_dia +#ifdef ODA + use mod_oda +#endif +c + use mod_state, only: temp, saln, dp, init_fluxes + implicit none +c + real q + integer i,m,n,mm,nn,k1m,k1n + logical update_flux_halos +c + real total_step_time, + . auxil_time , + . getfrc_time, + . tmsmt1_time, + . advdif_time, + . sfcstr_time, + . momtum_time, + . pgforc_time, + . barotp_time, + . pbcor2_time, + . convec_time, + . diapfl_time, + . thermf_time, + . mxlayr_time, + . tmsmt2_time, + . diaacc_time, + . io_time +c +c --- letter 'm' refers to mid-time level (example: dp(i,j,km) ) +c --- letter 'n' refers to old and new time level +c + m=mod(nstep ,2)+1 + n=mod(nstep+1,2)+1 + mm=(m-1)*kk + nn=(n-1)*kk + k1m=1+mm + k1n=1+nn +c + call budget_sums(1,n,nn) +c + call step_time +c +c --- ------------------------------------------------------------------ +c --- Reset fluxes to be accumulated over a model time step and update +c --- flux halos the first time step of a day to reproduce results after +c --- restart with tripolar grid. +c --- ------------------------------------------------------------------ +c + update_flux_halos = nreg == 2 .and. mod(nstep,nstep_in_day) == 1 + call init_fluxes(m,n,mm,nn,k1m,k1n,update_flux_halos) +c + auxil_time=get_time() +c +c --- ------------------------------------------------------------------ +c --- Get forcing +c --- ------------------------------------------------------------------ +c + call getfrc +c +c --- ------------------------------------------------------------------ +c --- Update arrays related to shortwave radiation absorption. +c --- ------------------------------------------------------------------ +c + call updswa +c + getfrc_time=get_time() +c + if (vcoord_type_tag == cntiso_hybrid) then + call cntiso_hybrid_regrid_remap(m,n,mm,nn,k1m,k1n) + call remap_velocity(m,n,mm,nn,k1m,k1n) + convec_time=get_time() + call budget_sums(2,n,nn) + endif +c + call cmnfld2(m,n,mm,nn,k1m,k1n) +c +cdiag write (lp,*) 'tmsmt1...' + call tmsmt1(m,n,mm,nn,k1m,k1n) + tmsmt1_time=get_time() +c +cdiag write (lp,*) 'advdif...' + if (vcoord_type_tag == isopyc_bulkml) then + call difest_isobml(m,n,mm,nn,k1m,k1n) + else + call difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) + endif + call eddtra(m,n,mm,nn,k1m,k1n) + call advect(m,n,mm,nn,k1m,k1n) + call pbcor1(m,n,mm,nn,k1m,k1n) + call diffus(m,n,mm,nn,k1m,k1n) + advdif_time=get_time() +c + if (vcoord_type_tag == isopyc_bulkml) then + call budget_sums(2,n,nn) + else + call budget_sums(3,n,nn) + endif + auxil_time=auxil_time+get_time() +c +cdiag write (lp,*) 'sfcstr...' + call sfcstr(m,n,mm,nn,k1m,k1n) + sfcstr_time=get_time() +c +cdiag write (lp,*) 'pgforc...' + call pgforc(m,n,mm,nn,k1m,k1n) + pgforc_time=get_time() +c +cdiag write (lp,*) 'momtum...' + call momtum(m,n,mm,nn,k1m,k1n) + momtum_time=get_time() +c + if (vcoord_type_tag == isopyc_bulkml) then +c +cdiag write (lp,*) 'convec...' + call convec(m,n,mm,nn,k1m,k1n) + convec_time=get_time() +c + call budget_sums(3,n,nn) + auxil_time=auxil_time+get_time() +c +cdiag write (lp,*) 'diapfl...' + call diapfl(m,n,mm,nn,k1m,k1n) + diapfl_time=get_time() +c + call budget_sums(4,n,nn) + auxil_time=auxil_time+get_time() +c + endif +c +cdiag write (lp,*) 'thermf...' + call thermf(m,n,mm,nn,k1m,k1n) + thermf_time=get_time() +c + if (vcoord_type_tag == isopyc_bulkml) then +cdiag write (lp,*) 'mxlayr...' + call mxlayr(m,n,mm,nn,k1m,k1n) + mxlayr_time=get_time() + else + call cmnfld_bfsqi_cntiso_hybrid(m,n,mm,nn,k1m,k1n) + call cntiso_hybrid_forcing(m,n,mm,nn,k1m,k1n) + call difest_vertical_hybrid(m,n,mm,nn,k1m,k1n) + mxlayr_time=get_time() + call cntiso_hybrid_vdifft(m,n,mm,nn,k1m,k1n) + call cntiso_hybrid_vdiffm(m,n,mm,nn,k1m,k1n) + call budget_sums(4,n,nn) + diapfl_time=get_time() + endif +c +#ifdef TRC +c --- update tracer due to non-passive processes + call updtrc(m,n,mm,nn,k1m,k1n) +#endif +c + call budget_sums(5,n,nn) + auxil_time=auxil_time+get_time() +c +cdiag write (lp,*) 'barotp...' + call barotp(m,n,mm,nn,k1m,k1n) + barotp_time=get_time() +c +cdiag write (lp,*) 'pbcor2...' + call pbcor2(m,n,mm,nn,k1m,k1n) + pbcor2_time=get_time() +c + call budget_sums(6,m,mm) + auxil_time=auxil_time+get_time() +c +cdiag write (lp,*) 'tmsmt2...' + call tmsmt2(m,n,mm,nn,k1m,k1n) + tmsmt2_time=get_time() +c + call budget_sums(7,m,mm) +c + call cmnfld1(m,n,mm,nn,k1m,k1n) +c +#ifdef ODA + call oda() +#endif + call diaacc(m,n,mm,nn,k1m,k1n) + diaacc_time=get_time() +c + call fwbbal(m,n,mm,nn,k1m,k1n) +c + call budget_output(m) +c + auxil_time=auxil_time+get_time() +c +c ---------------------------------------------------------------------- +c +c --- output and diagnostic calculations +c +c ---------------------------------------------------------------------- +c + call chkvar(m,n,mm,nn,k1m,k1n) +c + if (mod(nstep,nstep_in_day).eq.0.and.nday_of_year.eq.1) then +c +c --- ------------------------------------------------------------------ +c --- - output diagnosed heat and salt flux +c --- ------------------------------------------------------------------ +c + call wdiflx +c + endif +c +c --- ------------------------------------------------------------------ +c --- - output of BLOM diagnostics +c --- ------------------------------------------------------------------ +c + do i=1,nphy + if (((diagann_phy(i).and.nday_of_year.eq.1.or.diagmon_phy(i) + . .and.date%day.eq.1).and.mod(nstep,nstep_in_day).eq.0).or. + . .not.(diagann_phy(i).or.diagmon_phy(i)).and. + . mod(nstep+.5,diagfq_phy(i)).lt.1.) + . call diaout(i,m,n,mm,nn,k1m,k1n) + enddo +c +c --- update total time spent by various tasks + auxil_total_time=auxil_total_time+auxil_time + getfrc_total_time=getfrc_total_time+getfrc_time + tmsmt1_total_time=tmsmt1_total_time+tmsmt1_time + advdif_total_time=advdif_total_time+advdif_time + sfcstr_total_time=sfcstr_total_time+sfcstr_time + momtum_total_time=momtum_total_time+momtum_time + pgforc_total_time=pgforc_total_time+pgforc_time + barotp_total_time=barotp_total_time+barotp_time + pbcor2_total_time=pbcor2_total_time+pbcor2_time + convec_total_time=convec_total_time+convec_time + diapfl_total_time=diapfl_total_time+diapfl_time + thermf_total_time=thermf_total_time+thermf_time + mxlayr_total_time=mxlayr_total_time+mxlayr_time + tmsmt2_total_time=tmsmt2_total_time+tmsmt2_time + diaacc_total_time=diaacc_total_time+diaacc_time +c + if (((rstann.and.nday_of_year.eq.1.or.rstmon.and.date%day.eq.1) + . .and.mod(nstep,nstep_in_day).eq.0).or. + . .not.(rstann.or.rstmon).and.mod(nstep+.5,rstfrq).lt.1.) then +c + if (expcnf.ne.'cesm') then +c +c --- ------------------------------------------------------------------ +c --- --- output restart files +c --- ------------------------------------------------------------------ +c + call restart_wt +c + endif +c + io_time=get_time() +c +c --- ------------------------------------------------------------------ +c --- - write timing diagnostics to standard out +c --- ------------------------------------------------------------------ +c + io_total_time=io_total_time+io_time + total_step_time=auxil_time +getfrc_time+tmsmt1_time+advdif_time + . +sfcstr_time+momtum_time+pgforc_time+barotp_time + . +pbcor2_time+convec_time+diapfl_time+thermf_time + . +mxlayr_time+tmsmt2_time+diaacc_time+io_time + total_time=total_time+total_step_time + total_xio_time=total_xio_time+total_step_time-io_time +c + if (mnproc.eq.1) then + write (lp,'(f12.4,a,i8)') + . total_step_time, ' sec for step ', nstep + write (lp,'(f12.4,a,i8)') + . total_time/(nstep-nstep1),' Avg Time' + write (lp,'(f12.4,a,i8)') + . total_xio_time/(nstep-nstep1),' Avg Time excluding IO' + write (lp,'(f12.4,a,i8)') + . total_time,' Tot Time with contributions:' + q=100./total_time + write (lp,'(f12.4,a,i8)') auxil_total_time*q ,'% auxil ' + write (lp,'(f12.4,a,i8)') getfrc_total_time*q,'% getfrc' + write (lp,'(f12.4,a,i8)') tmsmt1_total_time*q,'% tmsmt1' + write (lp,'(f12.4,a,i8)') advdif_total_time*q,'% advdif' + write (lp,'(f12.4,a,i8)') sfcstr_total_time*q,'% sfcstr' + write (lp,'(f12.4,a,i8)') momtum_total_time*q,'% momtum' + write (lp,'(f12.4,a,i8)') pgforc_total_time*q,'% pgforc' + write (lp,'(f12.4,a,i8)') barotp_total_time*q,'% barotp' + write (lp,'(f12.4,a,i8)') pbcor2_total_time*q,'% pbcor2' + write (lp,'(f12.4,a,i8)') convec_total_time*q,'% convec' + write (lp,'(f12.4,a,i8)') diapfl_total_time*q,'% diapfl' + write (lp,'(f12.4,a,i8)') thermf_total_time*q,'% thermf' + write (lp,'(f12.4,a,i8)') mxlayr_total_time*q,'% mxlayr' + write (lp,'(f12.4,a,i8)') tmsmt2_total_time*q,'% tmsmt2' + write (lp,'(f12.4,a,i8)') diaacc_total_time*q,'% diaacc' + write (lp,'(f12.4,a,i8)') io_total_time*q ,'% IO' + endif +c + else +c +c --- ------------------------------------------------------------------ +c --- - write time spent for current time step +c --- ------------------------------------------------------------------ +c + io_time=get_time() + io_total_time=io_total_time+io_time + total_step_time=auxil_time +getfrc_time+tmsmt1_time+advdif_time + . +sfcstr_time+momtum_time+pgforc_time+barotp_time + . +pbcor2_time+convec_time+diapfl_time+thermf_time + . +mxlayr_time+tmsmt2_time+diaacc_time+io_time + total_time=total_time+total_step_time + total_xio_time=total_xio_time+total_step_time-io_time +c + if (mnproc.eq.1) then + write (lp,'(f12.4,a,i8)') total_step_time, ' sec for step ', + . nstep + endif +c + endif +c + delt1=baclin+baclin +c + return + end diff --git a/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/mod_oda.F b/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/mod_oda.F new file mode 100644 index 00000000..917b1eda --- /dev/null +++ b/setup/noresm2/user_mods/noresm2-lmesm_128pes/SourceMods/src.blom/mod_oda.F @@ -0,0 +1,222 @@ + module mod_oda +c + use dimensions + use mod_xc + use mod_nctools + use mod_dia + use mod_time + use mod_state +c + implicit none + + contains + + subroutine oda() +c + implicit none +c + logical :: ldooda,ldooda_daily,ldooda_monthly,lpause + if (mod(nstep+nint(0.5*nstep_in_day),nstep_in_day).ne.0) return + inquire(file='../../ANALYSIS/BLOM_DA_DAILY',exist=ldooda_daily) + inquire(file='../../ANALYSIS/BLOM_DA_MONTHLY', + . exist=ldooda_monthly) + if (ldooda_daily) then + ldooda = .true. + else if (ldooda_monthly .and. date%day .eq. 15) then + ldooda = .true. + else + ldooda = .false. + end if + if (ldooda) then + if (mnproc.eq.1) then + write (lp,*) 'Perform ODA ', date%year, date%month, date%day + endif +c + call restart_wt_oda +c + if (mnproc.eq.1) then + write(lp,*)'ODA pause at ',rdate() + open(unit=999,file='../../ANALYSIS/BLOM_PAUSE_'//member_tag() + . //'_'//rdate(),status='replace',action='write') + write(999,'(A)') rdate() + close(999) + lpause = .true. + do while ( lpause ) + call sleepqq(100) !! for sleep 0.1 sec + inquire(file='../../ANALYSIS/BLOM_PAUSE_'//member_tag()//'_' + . //rdate(),exist=lpause) + end do + write(lp,*)'ODA pause finished, continue run' + end if + call restart_rd_oda + else + write (lp,*) 'Skip ODA ', date%year, date%month, date%day + endif +c + end subroutine oda + + + character(len=3) function member_tag() +c + implicit none +c + character(len=3), save :: member_tag_saved='UNS' + character(len=512) :: rundir +c + if (member_tag_saved.eq.'UNS') then + call getcwd(rundir) + member_tag_saved=rundir(LEN_TRIM(rundir)-6:LEN_TRIM(rundir)-4) + end if + member_tag = member_tag_saved +c + end function member_tag + + + character(len=10) function rdate() +c + implicit none +c + write(rdate,'(i4.4,"-",i2.2,"-",i2.2)') + . date%year,date%month,date%day +c + end function rdate + + + character(len=512) function rstfnm_oda() +c + implicit none +c + rstfnm_oda = + . "../../ANALYSIS/blom.rda."//member_tag()//"."//rdate()//".nc" +c + end function rstfnm_oda + + + subroutine restart_rd_oda +c +c --- ------------------------------------------------------------------ +c --- Read initial conditions from restart file +c --- ------------------------------------------------------------------ +c +c + implicit none +c + character(len=512) :: rstfnm +c +c --- - open restart file + rstfnm = rstfnm_oda() + call ncfopn(rstfnm,'r',' ',1,iotype) +c + if (mnproc.eq.1) then + write (lp,'(2a)') ' restart_rd_oda: reading ODA restart file ', + . trim(rstfnm) + endif +c + call ncread('dp',dp,ip,1,0.) + call ncread('temp',temp,ip,1,0.) + call ncread('saln',saln,ip,1,0.) +c + call ncfcls +c +c --- delete file + if (mnproc.eq.1) then + open(unit=999, file=rstfnm, status='old') + close(999, status='delete') + end if +c +c --- copy data from time level 1 to level 2 + dp(:,:,kk+1:) = dp(:,:,:kk) + temp(:,:,kk+1:) = temp(:,:,:kk) + saln(:,:,kk+1:) = saln(:,:,:kk) +c + return + end subroutine restart_rd_oda + + + subroutine restart_wt_oda +c +c --- ------------------------------------------------------------------ +c --- Write model state to restart files +c --- ------------------------------------------------------------------ +c + implicit none +c + character(len=512) :: rstfnm +c +c --- average two time levels +c + dp(:,:,:kk) = 0.5 * (dp(:,:,1:kk)+dp(:,:,kk+1:)) + temp(:,:,:kk) = 0.5 * (temp(:,:,1:kk)+temp(:,:,kk+1:)) + saln(:,:,:kk) = 0.5 * (saln(:,:,1:kk)+saln(:,:,kk+1:)) +c +c --- open DA restart file +c + rstfnm = rstfnm_oda() +c + call ncfopn(rstfnm,'w','6',1,iotype) + call ncputi('nday0',date0%day) + call ncputi('nmonth0',date0%month) + call ncputi('nyear0',date0%year) + call ncputr('time0',time0) + call ncputr('time',time) +c +c --- define spatial and time dimensions + call ncdims('x',itdm) + call ncdims('y',jtdm) + call ncdims('kk',kk) + call ncdims('time',1) +c +c --- output model fields to restart file +c + call defvarrst('dp','x y kk time') + call defvarrst('temp','x y kk time') + call defvarrst('saln','x y kk time') +c + call ncedef +c + call wrtrst('dp','x y kk time',dp(:,:,:kk),ip) + call wrtrst('temp','x y kk time',temp(:,:,:kk),ip) + call wrtrst('saln','x y kk time',saln(:,:,:kk),ip) +c + call ncfcls +c + return + end + + + subroutine wrtrst(vnm,dims,fld,msk) +c +c --- ------------------------------------------------------------------ + use mod_xc + use mod_nctools +c + implicit none +c + character(len=*) :: vnm,dims + real, dimension(*) :: fld + integer, dimension(*) :: msk +c +c --- Write data in compressed or uncompressed format + if (dims(2:5).eq.'comp') then + call nccomp(vnm,dims,fld,msk,1.,0.,8) + else + call ncwrtr(vnm,dims,fld,msk,1,1.,0.,8) + endif +c + end + + + subroutine defvarrst(vnm,dims) +c +c --- ------------------------------------------------------------------ + use mod_nctools +c + implicit none +c + character(len=*) :: vnm,dims + + call ncdefvar(vnm,dims,ndouble,8) +c + end subroutine defvarrst + + end module mod_oda