text:
      SUBROUTINE PAKT50CH(T50,CHOUT)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE CONVERTS SECONDS SINCE 50/01/01, 0.0 HRS TO THE
C  FORM YY/MM/DD HH/MM/SS.SS
C
C  VARIABLE  DIM  TYPE I/O  DESCRIPTION
C  --------  ---  ---- ---  -----------
C
C  T50        1   R*8   I   TIME TO BE CONVERTED. IN SECONDS SINCE
C                           50/01/01, 0.0 HR.
C
C  CHOUT      1   CH*20 O   OUTPUT TIME IN FORM YY/MM/DD HH/MM/SS.SSS
C
C                           ONE CAN WRITE ALL OR PART OF THIS USING 'A'
C                           FORMAT. FOR EXAMPLE, TO SHOW THE MM/DD HH/MM
C                           PART, DO -
C                               WRITE(XX,101) ....., CHOUT(4:14), .....
C                           101 FORMAT(.....,A,........)
C                           YOU WILL GET 11 CHARACTERS PRINTED:
C                             M, M, /, D, D, blank, H, H, /, M, M
C
C***********************************************************************
C
C  BY C PETRUZZO, GSFC/742.1 3/85
C       MODIFIED...........
C
C***********************************************************************
C
      CHARACTER*20 CHOUT
      CHARACTER*8 I4CHAR,CHTEMP
C
      IF(T50.LT.0.D0) THEN
        CHOUT = '????????????????????'
        RETURN
        END IF
C
      CHOUT = 'YY/MM/DD HH/MM/SS.SS'
      TPACK = PAKTIM50(T50)
C
      KTEMP = TPACK
      CHTEMP = I4CHAR(KTEMP,6,KDUM)
      CHOUT(1:2) = CHTEMP(1:2)
      CHOUT(4:5) = CHTEMP(3:4)
      CHOUT(7:8) = CHTEMP(5:6)
C
      KTEMP = JIDNNT( DMOD(TPACK,1.D0)*1.D8 )
      CHTEMP = I4CHAR(KTEMP,8,KDUM)
      CHOUT(10:11) = CHTEMP(1:2)
      CHOUT(13:14) = CHTEMP(3:4)
      CHOUT(16:17) = CHTEMP(5:6)
      CHOUT(19:20) = CHTEMP(7:8)
C
      DO 100 I = 1,20
      IF(CHOUT(I:I).EQ.' ') CHOUT(I:I)='0'
  100 CONTINUE
      CHOUT(9:9) = ' '
C
C
      RETURN
      END

ext: for


text:
req_XArbiter.sv
req_XMatrix.sv
req_XRouter.sv
rsp_XArbiter.sv
rsp_XMatrix.sv
rsp_XRouter.sv
XSwitch.sv
XCommon.sv
XArbiter_RR.sv
XFifo.sv
XAFifo.sv
XMem.sv
XPktTrans.sv
XFabric.sv

ext: f

max_stars_repo_name: hanhha/XSwitchGen

max_issues_repo_name: hanhha/XSwitchGen

max_forks_repo_name: hanhha/XSwitchGen


text:
program passdata

  use, intrinsic :: iso_c_binding, only: c_double

  use RInside_interface

  implicit none

  type(SEXP) :: res
  type(SEXP), target :: vec
  real(c_double), pointer :: fvec(:) => null()

  call setupRinC()

  res = evalQuietlyInR("y <- 3")
  res = evalQuietlyInR("z <- 2.5")
  res = evalQuietlyInR("print(y*z)")
  res = evalQuietlyInR("y <- rnorm(10)")
  res = evalQuietlyInR("print(y)")

  ! The protect is added to prevent R from doing garbage collection
  vec = Rf_protect(evalInR("y"))

  call Rf_PrintValue(vec)

  ! fvec is a pointer to the underlying SEXP memory
  fvec => double_from_SEXP(vec,10)
  print *, fvec

  ! modifying fvec, changes the value in vec
  fvec(4) = 42
  call Rf_PrintValue(vec)

  ! We need to unprotect before teardown
  call Rf_unprotect(1)

  call teardownRinC()

end program

max_stars_repo_name: ivan-pi/fortran-Rinside

max_issues_repo_name: ivan-pi/fortran-Rinside

max_forks_repo_name: ivan-pi/fortran-Rinside


text:
MODULE mzprojection
!-------------------------------------------------------------------------------
!
!  Module of Mori-Zwanzig Projection operator method for data analysis
!
!    f(t) = Omega*u(t) - int_0^t Gamma(s)*u(t-s) ds + r(t)
!
!  Reference: S. Maeyama, T.-H. Watanabe, to be published JPSJ (2020).
!
!-------------------------------------------------------------------------------
  implicit none
  private

  public :: mzprojection_ensemble_of_time_series, &
            mzprojection_long_time_series

 CONTAINS

SUBROUTINE mzprojection_ensemble_of_time_series(  &
               nsample, nperiod, delta_t,         &
               u, dudt, f,                        &
               omega, memoryf, s, r,              &
               uu, ududt, fdudt, rr, rdudt, ru, fu, ff)
!-------------------------------------------------------------------------------
!
!  Evaluate projection of f(t) on u(t)
!
!    *User prepares ensembles of time-series data u(t)^i, du/dt(t)^i, f(t)^i
!
!-------------------------------------------------------------------------------
  implicit none
  != INPUT =
  integer,         intent(in)  :: nsample ! # of samples for ensemble average
  integer,         intent(in)  :: nperiod ! Length of a sample
  real(kind=8),    intent(in)  :: delta_t ! Time step size
  complex(kind=8), intent(in)  ::    u(0:nsample-1,0:nperiod-1) ! Variable u(t)
  complex(kind=8), intent(in)  :: dudt(0:nsample-1,0:nperiod-1) ! = du/dt
  complex(kind=8), intent(in)  ::    f(0:nsample-1,0:nperiod-1) ! Analyzed f(t)
  != OUTPUT =
  complex(kind=8), intent(out) :: omega                      ! Markov coefficient Omega
  complex(kind=8), intent(out) :: memoryf(0:nperiod-1)       ! Memory function Gamma(t)
  complex(kind=8), intent(out) :: s(0:nsample-1,0:nperiod-1) ! Memory term
  complex(kind=8), intent(out) :: r(0:nsample-1,0:nperiod-1) ! Uncorrelated term r(t)
  != OUTPUT for check =
  complex(kind=8), intent(out) ::    uu(0:nperiod-1) ! Correlation <u(t)u>
  complex(kind=8), intent(out) :: ududt(0:nperiod-1) ! Correlation <u(t)du/dt>
  complex(kind=8), intent(out) :: fdudt(0:nperiod-1) ! Correlation <f(t)du/dt>
  complex(kind=8), intent(out) ::    rr(0:nperiod-1) ! Correlation <r(t)r>
  complex(kind=8), intent(out) :: rdudt(0:nperiod-1) ! Correlation <r(t)du/dt>
  complex(kind=8), intent(out) ::    ru(0:nperiod-1) ! Correlation <r(t)u>
  complex(kind=8), intent(out) ::    fu(0:nperiod-1) ! Correlation <f(t)u>
  complex(kind=8), intent(out) ::    ff(0:nperiod-1) ! Correlation <f(t)f>

  integer :: iperiod, isample

    != Evaluate Markov coefficient Omega =
    omega = sum(f(0:nsample-1,0)*conjg(u(0:nsample-1,0)))  &
          / sum(u(0:nsample-1,0)*conjg(u(0:nsample-1,0)))

    != Evaluate memory function Gamma(t) =
    do iperiod = 0, nperiod-1
         uu(iperiod) = sum(u(0:nsample-1,iperiod) * conjg(   u(0:nsample-1,0))) / nsample
      ududt(iperiod) = sum(u(0:nsample-1,iperiod) * conjg(dudt(0:nsample-1,0))) / nsample
      fdudt(iperiod) = sum(f(0:nsample-1,iperiod) * conjg(dudt(0:nsample-1,0))) / nsample
    end do
    !- 2nd-order solver for memory equation -
    memoryf(0) = (fdudt(0) - omega*ududt(0)) / uu(0)
    memoryf(1) = (fdudt(1) - omega*ududt(1) + memoryf(0)*ududt(1)*0.5d0*delta_t) / uu(0)
    memoryf(1) = memoryf(1) / (1.d0 - ududt(0)*0.5d0*delta_t/uu(0))
    do iperiod = 2, nperiod-1
      memoryf(iperiod) = (fdudt(iperiod) - omega*ududt(iperiod)    &
                       + memoryf(0)*ududt(iperiod)*0.5d0*delta_t  &
                       + sum(memoryf(1:iperiod-1)*ududt(iperiod-1:1:-1))*delta_t) / uu(0)
      memoryf(iperiod) = memoryf(iperiod) / (1.d0 - ududt(0)*0.5d0*delta_t/uu(0))
    end do
    !-

    != Evaluate uncorrelated term r(t) as a residual =
    !- 2nd-order integration for memory term s(t) -
    s(:,0) = 0.d0
    r(:,0) = f(:,0) - omega*u(:,0)
    do iperiod = 1, nperiod-1
      do isample = 0, nsample-1
        s(isample,iperiod) = - (sum(memoryf(0:iperiod)*u(isample,iperiod:0:-1))*delta_t  &
                             - memoryf(0)*u(isample,iperiod) *0.5d0*delta_t              &
                             - memoryf(iperiod)*u(isample,0) *0.5d0*delta_t)
        r(isample,iperiod) = f(isample,iperiod) - omega*u(isample,iperiod) - s(isample,iperiod)
      end do
    end do
    !-

    != For check memory function and <r(t)u>=0 =
    do iperiod = 0, nperiod-1
         rr(iperiod) = sum(r(0:nsample-1,iperiod) * conjg(   r(0:nsample-1,0))) / nsample
      rdudt(iperiod) = sum(r(0:nsample-1,iperiod) * conjg(dudt(0:nsample-1,0))) / nsample
         ru(iperiod) = sum(r(0:nsample-1,iperiod) * conjg(   u(0:nsample-1,0))) / nsample
         fu(iperiod) = sum(f(0:nsample-1,iperiod) * conjg(   u(0:nsample-1,0))) / nsample
         ff(iperiod) = sum(f(0:nsample-1,iperiod) * conjg(   f(0:nsample-1,0))) / nsample
    end do

    !%%% NOTE %%%
    !% Since the above s, r is defined from u(isample,:) and f(isample,:),
    !%     s(isample,0) = 0
    !% is always imposed. Then, <s(t)s>=0, because s(0)=0.
    !% However, after a long time, s and r is also expected to be in a statistically
    !% steady state, <s(t)s> = <s(t+x)s(x)> /= 0.
    !%%%%%%%%%%%%%%%

END SUBROUTINE mzprojection_ensemble_of_time_series

SUBROUTINE mzprojection_long_time_series(             &
               nrec, ista, nperiod, nshift, delta_t,  &
               u_raw, dudt_raw, f_raw,                &
               omega, memoryf, s_raw, r_raw,          &
               uu, ududt, fdudt, rr, rdudt, ru, fu, ff)
!-------------------------------------------------------------------------------
!
!  Evaluate projection of f(t) on u(t)
!
!    *User prepares long time-series data u(t), du/dt(t), f(t)
!
!-------------------------------------------------------------------------------
  implicit none
  != INPUT =
  integer,         intent(in)  :: nrec      ! Total record number
  integer,         intent(in)  :: ista      ! Start record number for sampling
  integer,         intent(in)  :: nperiod   ! Length of a sample
  integer,         intent(in)  :: nshift    ! Length of time shift while sampling
  real(kind=8),    intent(in)  :: delta_t   ! Time step size
  complex(kind=8), intent(in)  ::    u_raw(0:nrec-1) ! Variable of interest u(t)
  complex(kind=8), intent(in)  :: dudt_raw(0:nrec-1) ! = du/dt
  complex(kind=8), intent(in)  ::    f_raw(0:nrec-1) ! Analyzed data f(t)
  != OUTPUT =
  complex(kind=8), intent(out) :: omega                ! Markov coefficient Omega
  complex(kind=8), intent(out) :: memoryf(0:nperiod-1) ! Memory function Gamma(t)
  complex(kind=8), intent(out) :: s_raw(0:nrec-1)      ! Memory term
  complex(kind=8), intent(out) :: r_raw(0:nrec-1)      ! Uncorrelated term r(t)
  != OUTPUT for check =
  complex(kind=8), intent(out) ::    uu(0:nperiod-1) ! Correlation <u(t)u>
  complex(kind=8), intent(out) :: ududt(0:nperiod-1) ! Correlation <u(t)du/dt>
  complex(kind=8), intent(out) :: fdudt(0:nperiod-1) ! Correlation <f(t)du/dt>
  complex(kind=8), intent(out) ::    rr(0:nperiod-1) ! Correlation <r(t)r>
  complex(kind=8), intent(out) :: rdudt(0:nperiod-1) ! Correlation <r(t)du/dt>
  complex(kind=8), intent(out) ::    ru(0:nperiod-1) ! Correlation <r(t)u>
  complex(kind=8), intent(out) ::    fu(0:nperiod-1) ! Correlation <f(t)u>
  complex(kind=8), intent(out) ::    ff(0:nperiod-1) ! Correlation <f(t)f>

  integer :: nsample_raw ! Number of samples for ensemble average
  complex(kind=8), dimension(0:(nrec-ista-nperiod)/nshift) ::  &
              u0, dudt0, f0, s0, r0, &! Initial values of sample u(0)
              u,  dudt,  f,  s,  r    ! Temporal valudes of samples u(t)
  integer :: irec, iperiod, isample

    nsample_raw = (nrec-ista-nperiod)/nshift + 1

    != Split raw data into ensembles =
    !!!!nsample_raw = (nrec-ista-nperiod)/nshift
    !!!!do isample = 0, nsample_raw-1
    !!!!  do iperiod = 0, nperiod-1
    !!!!    irec = ista + nshift * isample + iperiod
    !!!!    u(isample,iperiod) = u_raw(irec)
    !!!!    dudt(isample,iperiod) = dudt_raw(irec)
    !!!!    f(isample,iperiod) = f_raw(irec)
    !!!!  end do
    !!!!end do
    iperiod = 0
      do isample = 0, nsample_raw-1
        irec = ista + nshift * isample + iperiod
           u0(isample) = u_raw(irec)
        dudt0(isample) = dudt_raw(irec)
           f0(isample) = f_raw(irec)
      end do

    != Evaluate Markov correlation Omega =
    omega = sum(f0(0:nsample_raw-1)*conjg(u0(0:nsample_raw-1)))  &
          / sum(u0(0:nsample_raw-1)*conjg(u0(0:nsample_raw-1)))

    != Evaluate memory function Gamma(t) =
    do iperiod = 0, nperiod-1
      do isample = 0, nsample_raw-1
        irec = ista + nshift * isample + iperiod
           u(isample) = u_raw(irec)
        dudt(isample) = dudt_raw(irec)
           f(isample) = f_raw(irec)
      end do
         uu(iperiod) = sum(u(0:nsample_raw-1) * conjg(   u0(0:nsample_raw-1))) / nsample_raw
      ududt(iperiod) = sum(u(0:nsample_raw-1) * conjg(dudt0(0:nsample_raw-1))) / nsample_raw
      fdudt(iperiod) = sum(f(0:nsample_raw-1) * conjg(dudt0(0:nsample_raw-1))) / nsample_raw
      != For check <r(t)u>=0 =
         fu(iperiod) = sum(f(0:nsample_raw-1) * conjg(   u0(0:nsample_raw-1))) / nsample_raw
         ff(iperiod) = sum(f(0:nsample_raw-1) * conjg(   f0(0:nsample_raw-1))) / nsample_raw
    end do
    !- 2nd-order solver for memory equation -
    memoryf(0) = (fdudt(0) - omega*ududt(0)) / uu(0)
    memoryf(1) = (fdudt(1) - omega*ududt(1) + memoryf(0)*ududt(1)*0.5d0*delta_t) / uu(0)
    memoryf(1) = memoryf(1) / (1.d0 - ududt(0)*0.5d0*delta_t/uu(0))
    do iperiod = 2, nperiod-1
      memoryf(iperiod) = (fdudt(iperiod) - omega*ududt(iperiod)    &
                       + memoryf(0)*ududt(iperiod)*0.5d0*delta_t  &
                       + sum(memoryf(1:iperiod-1)*ududt(iperiod-1:1:-1))*delta_t) / uu(0)
      memoryf(iperiod) = memoryf(iperiod) / (1.d0 - ududt(0)*0.5d0*delta_t/uu(0))
    end do
    !-

    != Evaluate uncorrelated term r(t) as a residual =
    s_raw(0:ista-1) = 0.d0
    r_raw(0:ista-1) = 0.d0
    !- 2nd-order integration for memory term s(t) -
    s_raw(ista) = 0.d0
    r_raw(ista) = f_raw(ista) - omega*u_raw(ista)
    do irec = 1, nperiod-1
      s_raw(ista+irec) = - (sum(memoryf(0:irec)*u_raw(ista+irec:ista:-1)) *delta_t  &
                         - memoryf(0)*u_raw(ista+irec) *0.5d0*delta_t            &
                         - memoryf(irec)*u_raw(ista) *0.5d0*delta_t)
      r_raw(ista+irec) = f_raw(ista+irec) - omega*u_raw(ista+irec) - s_raw(ista+irec)
    end do
    do irec = ista+nperiod, nrec-1
      s_raw(irec) = - (sum(memoryf(0:nperiod-1)*u_raw(irec:irec-nperiod+1:-1)) *delta_t  &
                         - memoryf(0)*u_raw(irec) *0.5d0*delta_t                         &
                         - memoryf(nperiod-1)*u_raw(irec-nperiod+1) *0.5d0*delta_t)
      r_raw(irec) = f_raw(irec) - omega*u_raw(irec) - s_raw(irec)
    end do
    !-

    != For check memory function =
    !- 2nd-order integration for memory term s -
    iperiod = 0
      do isample = 0, nsample_raw-1
        irec = ista + nshift * isample + iperiod
        s0(isample) = (0.d0, 0.d0)
        r0(isample) = f_raw(irec) - omega*u_raw(irec)
      end do
         rr(iperiod) = sum(r0(0:nsample_raw-1) * conjg(   r0(0:nsample_raw-1))) / nsample_raw
      rdudt(iperiod) = sum(r0(0:nsample_raw-1) * conjg(dudt0(0:nsample_raw-1))) / nsample_raw
         ru(iperiod) = sum(r0(0:nsample_raw-1) * conjg(   u0(0:nsample_raw-1))) / nsample_raw
    do iperiod = 1, nperiod-1
      do isample = 0, nsample_raw-1
        irec = ista + nshift * isample + iperiod
        s(isample) = - (sum(memoryf(0:iperiod)*u_raw(irec:irec-iperiod:-1))*delta_t  &
                     - memoryf(0)*u_raw(irec) *0.5d0*delta_t              &
                     - memoryf(iperiod)*u_raw(irec-iperiod) *0.5d0*delta_t)
        r(isample) = f_raw(irec) - omega*u_raw(irec) - s(isample)
      end do
         rr(iperiod) = sum(r(0:nsample_raw-1) * conjg(   r0(0:nsample_raw-1))) / nsample_raw
      rdudt(iperiod) = sum(r(0:nsample_raw-1) * conjg(dudt0(0:nsample_raw-1))) / nsample_raw
         ru(iperiod) = sum(r(0:nsample_raw-1) * conjg(   u0(0:nsample_raw-1))) / nsample_raw
    end do
    !-

END SUBROUTINE mzprojection_long_time_series

END MODULE mzprojection

max_stars_repo_name: smaeyama/mzprojection

max_issues_repo_name: smaeyama/mzprojection

max_forks_repo_name: smaeyama/mzprojection


text:
        !COMPILER-GENERATED INTERFACE MODULE: Thu Feb  5 15:03:42 2015
        MODULE MA28INT2__genmod
          INTERFACE
            SUBROUTINE MA28INT2
            END SUBROUTINE MA28INT2
          END INTERFACE
        END MODULE MA28INT2__genmod

max_stars_repo_name: mtsafarzadeh/FLASHverES

max_issues_repo_name: mtsafarzadeh/FLASHverES

max_forks_repo_name: mtsafarzadeh/FLASHverES


text:
***********************************************************************
*                       SUBROUTINE CCFCSYM                            *
*                                                                     *
*                                                                     *
*  Purpose:  It determines whether the Charge Conjugate (CC),         *
*   Family Conjugate (FC) and CC+FC of a given processes have to      *
*   be summed upon by fxn.f (with the appropriate PDF) or some of     *
*   them are just the same process and must not be summed             *
*                                                                     *
*  The process is determined by the particle identities iproc(8)      *
*     iproc(1) and iproc(2) are incoming, the other six are outgoing  *
*                                                                     *
*      The CC, FC, CCFC processes are generated.                      *
*      Every one is compared  with the previous ones (including       *
*      iproc itself) and if different the corresponding flag is set   *
*      to 1                                                           *
*                                                                     *
*      iccsum =1 means  CC has to be summed                           *
*      ifcsum =1 means  FC has to be summed                           *
*      iccfcsum =1 means  CCFC has to be summed                       *
*                                                                     *
***********************************************************************

      subroutine CCFCSYM(iproc,iccsum,ifcsum,iccfcsum)

      implicit real*8 (a-h,o-z)

      dimension iproc(8),icc(8), ifc(8), iccfc(8)

      COMMON/phaones/ionesh

c   PDG  convention:
c   1=d, 2=u, 3=s, 4=c, 5=b, 6=t
c   11=e-, 12=v_e, 13=mu-, 14=v_mu, 15=tau-, 16=v_tau
c   all antiparticles have the same number but opposite sign
c   moreover: 21=gluon, 22=gamma, 23=Z0, 24=W+, 25=h

* charge conjugation array
*       Careful CC of non existing particles are set =0 !!!!
      INTEGER iccconj(-25:25)
      DATA    iccconj/
     &     0,24,0,0,0,0,0,0,0,16,15,14,13,12,11,0,0,0,0,6,5,4,3,2,1,0,
     &     -1,-2,-3,-4,-5,-6,0,0,0,0,-11,-12,-13,-14,-15,-16,
     &     0,0,0,0,21,22,23,-24,25 /

* family conjugation array
      INTEGER ifamconj(-25:25)
      DATA    ifamconj/
     &  -25,-24,-23,-22,-21,-20,-19,-18,-17,-16,
     &  -15,-14,-13,-12,-11,-10,-9,-8,-7,-6,-5,
     &         -2,-1,-4,-3,0,3,4,1,2,
     &  5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25 /

c initialization

      iccsum=0
      ifcsum=0
      iccfcsum=0

      do i=1,8
        icc(i)=iccconj(iproc(i))
        ifc(i)=ifamconj(iproc(i))
        iccfc(i)=iccconj(ifc(i))
      enddo

ctest
      if (ionesh.ne.1) then
        print*, 'iproc',iproc
        print*, 'icc  ',icc
        print*, 'ifc  ',ifc
        print*, 'iccfc',iccfc
      endif
ctestend

      call comptot(icc,iproc,idiv)
      if (idiv.eq.1) iccsum=1

      call comptot(ifc,iproc,idiv)
      if (idiv.eq.1.and.iccsum.eq.1) then
        call comptot(ifc,icc,idiv)
      endif
      if (idiv.eq.1) ifcsum=1

      call comptot(iccfc,iproc,idiv)
      if (idiv.eq.1.and.iccsum.eq.1) then
        call comptot(iccfc,icc,idiv)
      endif
      if (idiv.eq.1.and.ifcsum.eq.1) then
        call comptot(iccfc,ifc,idiv)
      endif
      if (idiv.eq.1) iccfcsum=1

      return
      end

***********************************************************************
*                     SUBROUTINE COMPTOT                              *
*                                                                     *
*  Purpose:  It determines whether two group of particles 8 particles *
*   iproc1 and iproc2  represent the same process apart from ordering.*
*  The first two particles of each group are assumed to be incoming,  *
*   the other six are outgoing. Therefore the two processes iproc1    *
*   and iproc2 are the same if the content of the first two is the    *
*   same AND the content of the second six is the same                *
*                                                                     *
*     idiv=1 if they two processes are not identical                  *
*     idiv=0 if they are identical                                    *
*                                                                     *
***********************************************************************

      subroutine comptot(iproc1,iproc2,idiv)
      dimension iproc1(8),iproc2(8)

      idiv=0
      call comp(iproc1,iproc2,2,idiv1)
      if (idiv1.eq.1) then
        idiv=1
      else
        call comp(iproc1(3),iproc2(3),6,idiv)
      endif

      return
      end

***********************************************************************
*                         SUBROUTINE COMP                             *
*                                                                     *
*  Purpose:  It determines whether two group of particles idp and ip  *
*     of dimension n (actually max n = 8, but it may be changed       *
*     in the parameter) are the same apart from their order.          *
*                                                                     *
*     idiv=1 if they are not identical                               *
*     idiv=0 if they are identical                                   *
*                                                                     *
***********************************************************************

      subroutine comp(idp,ip,n,idiv)
      parameter (maxn=8)
      dimension idp(maxn),ip(maxn),idploc(maxn)

      idiv=0

      do j=1,n
        idploc(j)=idp(j)
      enddo

      do j=1,n
        i=j
c   one compares ip(j) with  idploc(i) (i=j,n) . If none is
c    equal, i become greater than n  ad idiv is set to 1
c    if the i-th is equal, this is exchanged whith the one in position
c    j and one starts again
        do while(idploc(i).ne.ip(j).and.i.le.n)
          i=i+1
        enddo
        if (i.gt.n) then
          idiv=1
          return
        else
          iaux=idploc(j)
          idploc(j)=idploc(i)
          idploc(i)=iaux
        endif
      enddo

      return
      end

max_stars_repo_name: valsdav/vbscan-school

max_issues_repo_name: valsdav/vbscan-school

max_forks_repo_name: valsdav/vbscan-school


text:
      subroutine loop_minbound(n,m)
      integer t(100)
      do i = 0, min(n,m), 1
         t(i) = 0.
      enddo
      end


text:
  !! Block A and B
  IF (.NOT. IsATransposed) THEN
     CALL TransposeMatrix(matA,matAT)
  END IF
  IF (.NOT. IsBTransposed) THEN
     CALL TransposeMatrix(matB,matBT)
  END IF

  IF (IsATransposed .AND. IsBTransposed) THEN
     CALL MultiplyBlock(matA, matB, blocked_memory_pool)
  ELSEIF (IsATransposed) THEN
     CALL MultiplyBlock(matA, matBT, blocked_memory_pool)
  ELSEIF (IsBTransposed) THEN
     CALL MultiplyBlock(matAT, matB, blocked_memory_pool)
  ELSE
     CALL MultiplyBlock(matAT, matBT, blocked_memory_pool)
  END IF

  !! Go from triplets to return matrix
  CALL PruneList(blocked_memory_pool, alpha, threshold, &
       & blocked_memory_pool%columns, blocked_memory_pool%rows, matC)

max_stars_repo_name: Kokookster/NTPoly

max_issues_repo_name: omni-compiler/NTPoly

max_forks_repo_name: omni-compiler/NTPoly


text:
      COMPLEX*16 FUNCTION B0F_Wdec(Q2,MU2,M12,M22)
*     ---------------------------------------
* general B0F;
*
      IMPLICIT NONE
      REAL*8 MU2,Q2,ABQ2,DRM12,DRM22,RU,RD,B0FEXP_Wdec,DREAL,DABS,DLOG
      COMPLEX*16 M12,M22,SQR,SQS,ILQ,LOG,SQRT
*
      ABQ2=DABS(Q2)
      SQR=SQRT(Q2**2+2D0*Q2*(M12+M22)+(M12-M22)**2)
      SQS=Q2+M12+M22
      DRM12=DREAL(M12)
      DRM22=DREAL(M22)
*
* B0F(-M12;MU2,M12,0)
      IF(ABQ2.EQ.DRM12.AND.DRM22.EQ.0D0) THEN
        B0F_Wdec=2D0-DLOG(DRM12/MU2)
        RETURN
      ENDIF
* B0F(-M22;MU2,0,M22)
      IF(ABQ2.EQ.DRM22.AND.DRM12.EQ.0D0) THEN
        B0F_Wdec=2D0-DLOG(DRM22/MU2)
        RETURN
      ENDIF
*
      IF(ABQ2.NE.0D0) THEN
*
* B0F(Q2;MU2,M12,0)
       IF(DRM22.LT.1D-14) THEN
        B0F_Wdec=2D0-LOG(M12/MU2)-(1D0+M12/Q2)*LOG(1D0+Q2/M12)
        RETURN
       ENDIF
*
* B0F(Q2;MU2,0,M22)
       IF(DRM12.LT.1D-14) THEN
        B0F_Wdec=2D0-LOG(M22/MU2)-(1D0+M22/Q2)*LOG(1D0+Q2/M22)
        RETURN
       ENDIF
*
* TAYLOR EXPANSIONS: TO STABILIZE B0F(-SMALL,MU2,SMALL,M22)
       IF((ABQ2/DRM12.LT.1D-2).AND.(DRM22/DRM12.LT.1D-2)) THEN
        RU=(-Q2)/DRM12
        RD=DRM22/DRM12
        B0F_Wdec=B0FEXP_Wdec(RU,RD)-DLOG(DRM12/MU2)
        RETURN
       ELSEIF((ABQ2/DRM22.LT.1D-2).AND.(DRM12/DRM22.LT.1D-2)) THEN
        RU=(-Q2)/DRM22
        RD=DRM12/DRM22
        B0F_Wdec=B0FEXP_Wdec(RU,RD)-DLOG(DRM22/MU2)
        RETURN
       ENDIF
*
* B0F(Q2;MU2,M12,M22)
       IF(DREAL((SQS+SQR)/SQR).LT.1D-7) THEN
         ILQ=-SQR/Q2*LOG((SQS-SQR)/(2D0*SQRT(M12*M22)))
       ELSE
         ILQ=+SQR/Q2*LOG((SQS+SQR)/(2D0*SQRT(M12*M22)))
       ENDIF
       IF(DRM12.GT.1D-14.AND.DRM22.GT.1D-14) THEN
        B0F_Wdec=2D0-LOG(SQRT(M12*M22)/MU2)
     &          +(M12-M22)/2D0/Q2*LOG(M12/M22)-ILQ
       ELSEIF(DRM12.LE.1D-14.AND.DRM22.GT.1D-14) THEN
        B0F_Wdec=2D0-LOG(M22/MU2)-(1D0+M22/Q2)*LOG(1D0+Q2/M22)
       ELSEIF(DRM12.GT.1D-14.AND.DRM22.LE.1D-14) THEN
        B0F_Wdec=2D0-LOG(M12/MU2)-(1D0+M12/Q2)*LOG(1D0+Q2/M12)
       ELSEIF(DRM12.LE.1D-14.AND.DRM22.LE.1D-14) THEN
        B0F_Wdec=2D0-LOG(DCMPLX(Q2,-1D-20)/MU2)
       ELSE
        PRINT*,'NOT FORESEEN SET OF MASSES IN B0F: M12,M22=',M12,M22
        STOP
       ENDIF
*
      ELSEIF(ABQ2.EQ.0D0) THEN
*
* B0F(0;MU2,M12,M22)
       IF((DRM12.NE.DRM22).AND.DRM22.NE.0D0.AND.DRM12.NE.0D0) THEN
        B0F_Wdec=1D0-LOG(M22/MU2)-M12/(M12-M22)*LOG(M12/M22)
       ELSEIF(DRM12.EQ.0D0.AND.DRM22.NE.0D0) THEN
        B0F_Wdec=1D0-LOG(M22/MU2)
       ELSEIF(DRM12.NE.0D0.AND.DRM22.EQ.0D0) THEN
        B0F_Wdec=1D0-LOG(M12/MU2)
       ELSEIF(DRM12.EQ.DRM22) THEN
        B0F_Wdec=-LOG(M12/MU2)
       ELSE
        PRINT*,'B0F(0;...) NOT FORESEEN SET OF MASSES: M12,M22=',M12,M22
        STOP
       ENDIF
      ELSE
       PRINT*,'B0F(Q2;...) NOT FORESEEN SET OF MASSES: M12,M22=',M12,M22
      ENDIF
*
      RETURN
      END

      REAL*8 FUNCTION B0FEXP_Wdec(RU,RD)
*
      IMPLICIT NONE
      REAL*8 RU,RD,LNRD
*
      LNRD=DLOG(RD)
      B0FEXP_Wdec=1D0
     &     +LNRD*RD*(1D0+    RD       +RD**2+       RD**3+      RD**4)
     &+RU   *(1D0/2   +3D0/2*RD+ 5D0/2*RD**2+7D0/2 *RD**3+9D0/2*RD**4
     &     +LNRD*RD*(1D0+3D0*RD+   6D0*RD**2+10D0  *RD**3))
     &+RU**2*(1D0/6   +7D0/3*RD+17D0/2*RD**2+62D0/3*RD**3
     &     +LNRD*RD*(1D0+6D0*RD+20D0  *RD**2))
     &+RU**3*(1D0/12+35D0/12*RD+56D0/3*RD**2+LNRD*RD*(1D0+10D0*RD))
     &+RU**4*(1D0/20+101D0/30*RD+LNRD*RD)
     &+RU**5*(1D0/30)
*
      RETURN
      END

max_stars_repo_name: lukaszgaza/winhacplusplus

max_issues_repo_name: lukaszgaza/winhacplusplus

max_forks_repo_name: lukaszgaza/winhacplusplus


 SUBROUTINE DSYSV1_F95( A, B, UPLO, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: SYSV_F77 => LA_SYSV, ILAENV_F77 => ILAENV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:)
    REAL(WP), INTENT(INOUT) :: A(:,:), B(:)
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_SYSV'
    CHARACTER(LEN=6), PARAMETER :: BSNAME = 'DSYTRF'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, ISTAT, ISTAT1, SIPIV, N, LWORK, NB
!   .. LOCAL POINTERS ..
    INTEGER, POINTER :: LPIV(:)
    REAL(WP), POINTER :: WORK(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; N = SIZE(A,1)
    IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
    IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = SIZE(A,1); END IF
!   .. TEST THE ARGUMENTS
    IF( SIZE( A, 2 ) /= N .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B ) /= N ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF( SIPIV /= N )THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
!  .. DETERMINE THE WORKSPACE
      IF( PRESENT(IPIV) )THEN; LPIV => IPIV
      ELSE; ALLOCATE( LPIV(SIZE(A,1)), STAT = ISTAT ); END IF
      IF( ISTAT == 0 )THEN
         NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
         IF( NB <= 1 .OR. NB >= N ) NB = 1; LWORK = N*NB
         ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN
            DEALLOCATE(WORK, STAT=ISTAT1); LWORK = 3*N-1
            ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT /= 0 ) THEN; LINFO = - 100
            ELSE; CALL ERINFO( -200, SRNAME, LINFO ); ENDIF
         ENDIF
         IF ( ISTAT == 0 ) &
!           .. CALL LAPACK77 ROUTINE
            CALL SYSV_F77( LUPLO, N, 1, A, N, LPIV, B, N, WORK, LWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(IPIV) )DEALLOCATE(LPIV, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE DSYSV1_F95


text:
!
! Solar_IO
!
! Module containing routines to read and write Solar netCDF
! format files.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 15-Jan-2002
!                       paul.vandelst@noaa.gov
!

MODULE Solar_IO

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds     , ONLY: Long, Double
  USE Message_Handler, ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE File_Utility   , ONLY: File_Exists
  USE String_Utility , ONLY: StrClean
  USE Solar_Define   , ONLY: Solar_type          , &
                             Solar_Associated    , &
                             Solar_Destroy       , &
                             Solar_Create        , &
                             Solar_Inspect       , &
                             Solar_ValidRelease  , &
                             Solar_Info          , &
                             Solar_DefineVersion
  USE netcdf
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Procedures
  PUBLIC :: Solar_InquireFile
  PUBLIC :: Solar_ReadFile
  PUBLIC :: Solar_WriteFile
  PUBLIC :: Solar_IOVersion

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Default message string length
  INTEGER, PARAMETER :: ML = 1024
  ! Literal constants
  REAL(Double), PARAMETER :: ZERO = 0.0_Double

  ! Global attribute names. Case sensitive
  CHARACTER(*), PARAMETER :: RELEASE_GATTNAME    = 'Release'
  CHARACTER(*), PARAMETER :: VERSION_GATTNAME    = 'Version'
  CHARACTER(*), PARAMETER :: TITLE_GATTNAME      = 'Title'
  CHARACTER(*), PARAMETER :: HISTORY_GATTNAME    = 'History'
  CHARACTER(*), PARAMETER :: COMMENT_GATTNAME    = 'Comment'
  CHARACTER(*), PARAMETER :: SOURCE_GATTNAME     = 'Source'
  CHARACTER(*), PARAMETER :: REFERENCES_GATTNAME = 'References'

  ! Dimension names. Case sensitive
  CHARACTER(*), PARAMETER :: FREQUENCY_DIMNAME  = 'n_Frequencies'

  ! Variable names. Case sensitive.
  CHARACTER(*), PARAMETER :: TB_VARNAME        = 'Blackbody_Temperature'
  CHARACTER(*), PARAMETER :: RADIUS_VARNAME    = 'Radius'
  CHARACTER(*), PARAMETER :: AU_VARNAME        = 'Earth_Sun_Distance'
  CHARACTER(*), PARAMETER :: FREQUENCY_VARNAME = 'Frequency'
  CHARACTER(*), PARAMETER :: HSOLAR_VARNAME    = 'Irradiance'
  CHARACTER(*), PARAMETER :: HTB_VARNAME       = 'Blackbody_Irradiance'

  ! Variable long name attribute.
  CHARACTER(*), PARAMETER :: LONGNAME_ATTNAME = 'long_name'

  CHARACTER(*), PARAMETER :: TB_LONGNAME        = 'Solar Tb Source Temperature'
  CHARACTER(*), PARAMETER :: RADIUS_LONGNAME    = 'Solar Radius'
  CHARACTER(*), PARAMETER :: AU_LONGNAME        = 'Earth-Sun distance'
  CHARACTER(*), PARAMETER :: FREQUENCY_LONGNAME = 'Frequency'
  CHARACTER(*), PARAMETER :: HSOLAR_LONGNAME    = 'Solar Irradiance'
  CHARACTER(*), PARAMETER :: HTB_LONGNAME       = 'Solar Blackbody Irradiance'

  ! Description attribute.
  CHARACTER(*), PARAMETER :: DESCRIPTION_ATTNAME = 'description'

  CHARACTER(*), PARAMETER :: TB_DESCRIPTION        = 'Solar radiative temperature used to '//&
                                                     'generate the blackbody source function'
  CHARACTER(*), PARAMETER :: RADIUS_DESCRIPTION    = 'Radius of visible solar disk, or photosphere'
  CHARACTER(*), PARAMETER :: AU_DESCRIPTION        = 'Earth-Sun distance'
  CHARACTER(*), PARAMETER :: FREQUENCY_DESCRIPTION = 'Frequency of the solar and blackbody '//&
                                                     'irradiance spectra'
  CHARACTER(*), PARAMETER :: HSOLAR_DESCRIPTION    = 'Extraterrestrial TOA solar irradiance '//&
                                                     'using Kurucz spectrum'
  CHARACTER(*), PARAMETER :: HTB_DESCRIPTION       = 'Extraterrestrial TOA solar blackbody '//&
                                                     'irradiance using blackbody temperature'

  ! Variable units attribute.
  CHARACTER(*), PARAMETER :: UNITS_ATTNAME = 'units'

  CHARACTER(*), PARAMETER :: TB_UNITS        = 'Kelvin (K)'
  CHARACTER(*), PARAMETER :: RADIUS_UNITS    = 'Metres (m)'
  CHARACTER(*), PARAMETER :: AU_UNITS        = 'Metres (m)'
  CHARACTER(*), PARAMETER :: FREQUENCY_UNITS = 'Inverse centimetres (cm^-1)'
  CHARACTER(*), PARAMETER :: HSOLAR_UNITS    = 'mW/(m^2.cm^-1)'
  CHARACTER(*), PARAMETER :: HTB_UNITS       = 'mW/(m^2.cm^-1)'

  ! Variable _FillValue attribute.
  CHARACTER(*), PARAMETER :: FILLVALUE_ATTNAME = '_FillValue'

  REAL(Double), PARAMETER :: TB_FILLVALUE        = ZERO
  REAL(Double), PARAMETER :: RADIUS_FILLVALUE    = ZERO
  REAL(Double), PARAMETER :: AU_FILLVALUE        = ZERO
  REAL(Double), PARAMETER :: FREQUENCY_FILLVALUE = ZERO
  REAL(Double), PARAMETER :: HSOLAR_FILLVALUE    = ZERO
  REAL(Double), PARAMETER :: HTB_FILLVALUE       = ZERO

  ! Variable netCDF datatypes
  INTEGER, PARAMETER :: TB_TYPE        = NF90_DOUBLE
  INTEGER, PARAMETER :: RADIUS_TYPE    = NF90_DOUBLE
  INTEGER, PARAMETER :: AU_TYPE        = NF90_DOUBLE
  INTEGER, PARAMETER :: FREQUENCY_TYPE = NF90_DOUBLE
  INTEGER, PARAMETER :: HSOLAR_TYPE    = NF90_DOUBLE
  INTEGER, PARAMETER :: HTB_TYPE       = NF90_DOUBLE

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Solar_InquireFile
!
! PURPOSE:
!       Function to inquire Solar object data files.
!
! CALLING SEQUENCE:
!       Error_Status = Solar_InquireFile( &
!                        Filename                     , &
!                        n_Frequencies = n_Frequencies, &
!                        Release       = Release      , &
!                        Version       = Version      , &
!                        Title         = Title        , &
!                        History       = History      , &
!                        Comment       = Comment      , &
!                        Source        = Source       , &
!                        References    = References     )
!
! INPUTS:
!       Filename:           Character string specifying the name of the
!                           Solar data file to inquire.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
!       n_Frequencies:      Number of spectral frquencies.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Release:            The release number of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Version:            The version number of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Title:              Character string written into the TITLE global
!                           attribute field of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       History:            Character string written into the HISTORY global
!                           attribute field of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Comment:            Character string written into the COMMENT global
!                           attribute field of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Source:             Character string written into the SOURCE global
!                           attribute field of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       References:         Character string written into the REFERENCES global
!                           attribute field of the Solar file.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:       The return value is an integer defining the error
!                           status. The error codes are defined in the
!                           Message_Handler module.
!                           If == SUCCESS the file inquiry was successful
!                              == FAILURE an error occurred.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Solar_InquireFile( &
    Filename     , &  ! Input
    n_Frequencies, &  ! Optional output
    Release      , &  ! Optional output
    Version      , &  ! Optional Output
    Title        , &  ! Optional Output
    History      , &  ! Optional Output
    Comment      , &  ! Optional Output
    Source       , &  ! Optional Output
    References   ) &  ! Optional output
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Frequencies
    INTEGER     , OPTIONAL, INTENT(OUT) :: Release
    INTEGER     , OPTIONAL, INTENT(OUT) :: Version
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: History
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Source
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: References
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_InquireFile(netCDF)'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    INTEGER :: nf90_status
    INTEGER :: fileid
    INTEGER :: dimid
    TYPE(Solar_type) :: Solar

    ! Set up
    err_stat = SUCCESS
    close_file = .FALSE.

    ! Open the file
    nf90_status = NF90_OPEN( Filename,NF90_NOWRITE,fileid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error opening '//TRIM(Filename)//' for read access - '// &
            TRIM(NF90_STRERROR( nf90_status ))
      CALL Inquire_Cleanup(); RETURN
    END IF
    ! ...Close the file if any error from here on
    close_file = .TRUE.

    ! Get the dimensions
    ! ...n_Frequencies dimension
    NF90_Status = NF90_INQ_DIMID( FileId,FREQUENCY_DIMNAME,DimId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring dimension ID for '//FREQUENCY_DIMNAME//' - '// &
            TRIM(NF90_STRERROR( NF90_Status ))
      CALL Inquire_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=solar%n_Frequencies )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error reading dimension value for '//FREQUENCY_DIMNAME//' - '// &
            TRIM(NF90_STRERROR( NF90_Status ))
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Get the global attributes
    err_stat = ReadGAtts( Filename, &
                          fileid  , &
                          Release    = Release   , &
                          Version    = Version   , &
                          Title      = Title     , &
                          History    = History   , &
                          Comment    = Comment   , &
                          Source     = Source    , &
                          References = References  )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading global attributes from '//TRIM(Filename)
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Close the file
    nf90_status = NF90_CLOSE( fileid )
    close_file = .FALSE.
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error closing input file - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Set the return values
    IF ( PRESENT(n_Frequencies) ) n_Frequencies = Solar%n_Frequencies

  CONTAINS

    SUBROUTINE Inquire_CleanUp()
      IF ( close_file ) THEN
        nf90_status = NF90_CLOSE( fileid )
        IF ( nf90_status /= NF90_NOERR ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup.'
      END IF
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Inquire_CleanUp

  END FUNCTION Solar_InquireFile

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Solar_WriteFile
!
! PURPOSE:
!       Function to write Solar object data files.
!
! CALLING SEQUENCE:
!       Error_Status = Solar_WriteFile( &
!                        Filename               , &
!                        Solar                  , &
!                        Quiet      = Quiet     , &
!                        Title      = Title     , &
!                        History    = History   , &
!                        Comment    = Comment   , &
!                        Source     = Source    , &
!                        References = References  )
!
! INPUTS:
!       Filename:       Character string specifying the name of the
!                       Solar data file to write.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Solar:          Solar object containing the irradiance spectra.
!                       UNITS:      N/A
!                       TYPE:       Solar_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Title:          Character string written into the TITLE global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       History:        Character string written into the HISTORY global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Comment:        Character string written into the COMMENT global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Source:         Character string written into the SOURCE global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       References:     Character string written into the REFERENCES global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS the data write was successful
!                          == FAILURE an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Solar_WriteFile( &
    Filename  , &  ! Input
    Solar     , &  ! Input
    Quiet     , &  ! Optional input
    Title     , &  ! Optional input
    History   , &  ! Optional input
    Comment   , &  ! Optional input
    Source    , &  ! Optional input
    References) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN) :: Filename
    TYPE(Solar_type),       INTENT(IN) :: Solar
    LOGICAL,      OPTIONAL, INTENT(IN) :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Title
    CHARACTER(*), OPTIONAL, INTENT(IN) :: History
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Source
    CHARACTER(*), OPTIONAL, INTENT(IN) :: References
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_WriteFile(netCDF)'
    ! Local variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: nf90_status
    INTEGER :: fileid
    INTEGER :: varid

    ! Set up
    err_stat = SUCCESS
    close_file = .FALSE.
    ! ...Check structure pointer association status
    IF ( .NOT. Solar_Associated( Solar ) ) THEN
      msg = 'Solar structure is empty. Nothing to do!'
      CALL Write_CleanUp(); RETURN
    END IF
    ! ...Check if release is valid
    IF ( .NOT. Solar_ValidRelease( Solar ) ) THEN
      msg = 'Solar Release check failed.'
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet

    ! Create the output file
    err_stat = CreateFile( &
                 Filename                  , &
                 Solar%n_Frequencies       , &
                 fileid                    , &
                 Version    = Solar%Version, &
                 Title      = Title        , &
                 History    = History      , &
                 Comment    = Comment      , &
                 Source     = Source       , &
                 References = References     )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error creating output file '//TRIM(Filename)
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Close the file if any error from here on
    close_file = .TRUE.

    ! Write the data items
    ! ...Blackbody_Temperature variable
    NF90_Status = NF90_INQ_VARID( FileId,TB_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//TB_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Blackbody_Temperature )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//TB_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Radius variable
    NF90_Status = NF90_INQ_VARID( FileId,RADIUS_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//RADIUS_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Radius )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//RADIUS_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Earth_Sun_Distance variable
    NF90_Status = NF90_INQ_VARID( FileId,AU_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//AU_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Earth_Sun_Distance )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//AU_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Frequency variable
    NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Frequency )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//FREQUENCY_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Irradiance variable
    NF90_Status = NF90_INQ_VARID( FileId,HSOLAR_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//HSOLAR_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Irradiance )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//HSOLAR_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Blackbody_Irradiance variable
    NF90_Status = NF90_INQ_VARID( FileId,HTB_VARNAME,VarId )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//HTB_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF
    NF90_Status = NF90_PUT_VAR( FileId,VarID,Solar%Blackbody_Irradiance )
    IF ( NF90_Status /= NF90_NOERR ) THEN
      msg = 'Error writing '//HTB_VARNAME//' to '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( NF90_Status ))
      CALL Write_Cleanup(); RETURN
    END IF

    ! Close the file
    nf90_status = NF90_CLOSE( fileid )
    close_file = .FALSE.
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error closing output file - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Write_Cleanup(); RETURN
    END IF

    ! Output an info message
    IF ( noisy ) THEN
      CALL Solar_Info( Solar, msg )
      CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
    END IF

  CONTAINS

    SUBROUTINE Write_CleanUp()
      IF ( close_file ) THEN
        nf90_status = NF90_CLOSE( fileid )
        IF ( nf90_status /= NF90_NOERR ) &
          msg = TRIM(msg)//'; Error closing output file during error cleanup - '//&
                TRIM(NF90_STRERROR( nf90_status ))
      END IF
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Write_CleanUp

  END FUNCTION Solar_WriteFile

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Solar_ReadFile
!
! PURPOSE:
!       Function to read Solar object data files.
!
! CALLING SEQUENCE:
!       Error_Status = Solar_netCDF_ReadFile( &
!                        Filename               , &
!                        Solar                  , &
!                        Quiet      = Quiet     , &
!                        Title      = Title     , &
!                        History    = History   , &
!                        Comment    = Comment   , &
!                        Source     = Source    , &
!                        References = References  )
!
! INPUTS:
!       Filename:       Character string specifying the name of the
!                       Solar data file to write.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Solar:          Solar object containing the irradiance spectra.
!                       UNITS:      N/A
!                       TYPE:       Solar_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OPTIONAL OUTPUTS:
!       Title:          Character string written into the TITLE global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       History:        Character string written into the HISTORY global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Comment:        Character string written into the COMMENT global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Source:         Character string written into the SOURCE global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       References:     Character string written into the REFERENCES global
!                       attribute field of the Solar file.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS the data write was successful
!                          == FAILURE an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Solar_ReadFile( &
    Filename  , &  ! Input
    Solar     , &  ! Output
    Quiet     , &  ! Optional input
    Title     , &  ! Optional output
    History   , &  ! Optional output
    Comment   , &  ! Optional output
    Source    , &  ! Optional output
    References) &  ! Optional output
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    TYPE(Solar_type),       INTENT(OUT) :: Solar
    LOGICAL,      OPTIONAL, INTENT(IN)  :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: History
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Source
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: References
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_ReadFile(netCDF)'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: nf90_status
    INTEGER :: fileid
    INTEGER :: n_frequencies
    INTEGER :: varid

    ! Set up
    err_stat = SUCCESS
    close_file = .FALSE.
    ! ...Check that the file exists
    IF ( .NOT. File_Exists(Filename) ) THEN
      msg = 'File '//TRIM(Filename)//' not found.'
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet

    ! Inquire the file to get the dimensions
    err_stat = Solar_InquireFile( &
                 Filename, &
                 n_Frequencies = n_frequencies )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error obtaining Solar dimensions from '//TRIM(Filename)
      CALL Read_Cleanup(); RETURN
    END IF

    ! Allocate the output structure
    CALL Solar_Create( &
           Solar, &
           n_frequencies )
    IF ( .NOT. Solar_Associated(Solar) ) THEN
      msg = 'Error allocating output Solar'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Open the file for reading
    nf90_status = NF90_OPEN( Filename,NF90_NOWRITE,fileid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error opening '//TRIM(Filename)//' for read access - '//&
            TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Close the file if any error from here on
    close_file = .TRUE.

    ! Read the global attributes
    err_stat = ReadGAtts( &
                 Filename, &
                 fileid  , &
                 Release    = Solar%Release, &
                 Version    = Solar%Version, &
                 Title      = Title        , &
                 History    = History      , &
                 Comment    = Comment      , &
                 Source     = Source       , &
                 References = References     )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading global attribute from '//TRIM(Filename)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Check if release is valid
    IF ( .NOT. Solar_ValidRelease( Solar ) ) THEN
      msg = 'Solar Release check failed.'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Read the Solar data
    ! ...Blackbody_Temperature variable
    nf90_status = NF90_INQ_VARID( fileid,TB_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//TB_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Blackbody_Temperature )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//TB_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Radius variable
    nf90_status = NF90_INQ_VARID( fileid,RADIUS_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//RADIUS_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Radius )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//RADIUS_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Earth_Sun_Distance variable
    nf90_status = NF90_INQ_VARID( fileid,AU_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//AU_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Earth_Sun_Distance )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//AU_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Frequency variable
    nf90_status = NF90_INQ_VARID( fileid,FREQUENCY_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Frequency )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//FREQUENCY_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Irradiance variable
    nf90_status = NF90_INQ_VARID( fileid,HSOLAR_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//HSOLAR_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Irradiance )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//HSOLAR_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Blackbody_Irradiance variable
    nf90_status = NF90_INQ_VARID( fileid,HTB_VARNAME,varid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error inquiring '//TRIM(Filename)//' for '//HTB_VARNAME//&
            ' variable ID - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF
    nf90_status = NF90_GET_VAR( fileid,varid,Solar%Blackbody_Irradiance )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error reading '//HTB_VARNAME//' from '//TRIM(Filename)//&
            ' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF

    ! Set the frequency limit values
    solar%f1 = solar%Frequency(1)
    solar%f2 = solar%Frequency(solar%n_Frequencies)

    ! Close the file
    nf90_status = NF90_CLOSE( fileid ); CLOSE_FILE = .FALSE.
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error closing output file - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Read_Cleanup(); RETURN
    END IF

    ! Output an info message
    IF ( noisy ) THEN
      CALL Solar_Info( Solar, msg )
      CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
    END IF

  CONTAINS

    SUBROUTINE Read_CleanUp()
      IF ( close_file ) THEN
        nf90_status = NF90_CLOSE( fileid )
        IF ( nf90_status /= NF90_NOERR ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup- '//&
                TRIM(NF90_STRERROR( nf90_status ))
      END IF
      CALL Solar_Destroy( Solar )
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Read_CleanUp

  END FUNCTION Solar_ReadFile

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Solar_IOVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL Solar_IOVersion( Id )
!
! OUTPUT ARGUMENTS:
!       Id:            Character string containing the version Id information
!                      for the module.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Solar_IOVersion( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE Solar_IOVersion

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

  ! Function to write the global attributes to a Solar data file.

  FUNCTION WriteGAtts( &
    Filename  , &  ! Input
    FileId    , &  ! Input
    Version   , &  ! Optional input
    Title     , &  ! Optional input
    History   , &  ! Optional input
    Comment   , &  ! Optional input
    Source    , &  ! Optional input
    References) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN) :: Filename
    INTEGER     ,           INTENT(IN) :: FileId
    INTEGER     , OPTIONAL, INTENT(IN) :: Version
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Title
    CHARACTER(*), OPTIONAL, INTENT(IN) :: History
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Source
    CHARACTER(*), OPTIONAL, INTENT(IN) :: References
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_WriteGAtts(netCDF)'
    CHARACTER(*), PARAMETER :: WRITE_MODULE_HISTORY_GATTNAME   = 'write_module_history'
    CHARACTER(*), PARAMETER :: CREATION_DATE_AND_TIME_GATTNAME = 'creation_date_and_time'
    ! Local variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: gattname
    CHARACTER(8)  :: cdate
    CHARACTER(10) :: ctime
    CHARACTER(5)  :: czone
    INTEGER :: ver
    INTEGER :: nf90_status
    TYPE(Solar_type) :: Solar

    ! Set up
    err_stat = SUCCESS
    msg = ' '

    ! Mandatory global attributes
    ! ...Software ID
    gattname = WRITE_MODULE_HISTORY_GATTNAME
    nf90_status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(gattname),MODULE_VERSION_ID )
    IF ( nf90_status /= NF90_NOERR ) THEN
      CALL WriteGAtts_Cleanup(); RETURN
    END IF
    ! ...Creation date
    CALL DATE_AND_TIME( cdate, ctime, czone )
    gattname = CREATION_DATE_AND_TIME_GATTNAME
    nf90_status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(gattname), &
                                cdate(1:4)//'/'//cdate(5:6)//'/'//cdate(7:8)//', '// &
                                ctime(1:2)//':'//ctime(3:4)//':'//ctime(5:6)//' '// &
                                czone//'UTC' )
    IF ( nf90_status /= NF90_NOERR ) THEN
      CALL WriteGAtts_Cleanup(); RETURN
    END IF
    ! ...The Release
    gattname = RELEASE_GATTNAME
    nf90_status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(gattname),Solar%Release )
    IF ( nf90_status /= NF90_NOERR ) THEN
      CALL WriteGAtts_Cleanup(); RETURN
    END IF

    ! Optional global attributes
    ! ...The Version
    IF ( PRESENT(Version) ) THEN
      ver = Version
    ELSE
      ver = Solar%Version
    END IF
    gattname = VERSION_GATTNAME
    nf90_status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(gattname),Ver )
    IF ( nf90_status /= NF90_NOERR ) THEN
      CALL WriteGAtts_Cleanup(); RETURN
    END IF
    ! ...The Title
    IF ( PRESENT(Title) ) THEN
      gattname = TITLE_GATTNAME
      nf90_status = NF90_PUT_ATT( FileID,NF90_GLOBAL,TRIM(gattname),Title )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL WriteGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The History
    IF ( PRESENT(History) ) THEN
      gattname = HISTORY_GATTNAME
      nf90_status = NF90_PUT_ATT( FileID,NF90_GLOBAL,TRIM(gattname),History )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL WriteGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The Comment
    IF ( PRESENT(Comment) ) THEN
      gattname = COMMENT_GATTNAME
      nf90_status = NF90_PUT_ATT( FileID,NF90_GLOBAL,TRIM(gattname),Comment )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL WriteGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The Source
    IF ( PRESENT(Source) ) THEN
      gattname = SOURCE_GATTNAME
      nf90_status = NF90_PUT_ATT( FileID,NF90_GLOBAL,TRIM(gattname),Source )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL WriteGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The References
    IF ( PRESENT(References) ) THEN
      gattname = REFERENCES_GATTNAME
      nf90_status = NF90_PUT_ATT( FileID,NF90_GLOBAL,TRIM(gattname),References )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL WriteGAtts_Cleanup(); RETURN
      END IF
    END IF

 CONTAINS

    SUBROUTINE WriteGAtts_CleanUp()
      nf90_status = NF90_CLOSE( FileId )
      IF ( nf90_status /= NF90_NOERR ) &
        msg = '; Error closing input file during error cleanup - '//&
              TRIM(NF90_STRERROR( nf90_status ) )
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Error writing '//TRIM(gattname)//' attribute to '//&
                            TRIM(Filename)//' - '// &
                            TRIM(NF90_STRERROR( nf90_status ) )//TRIM(msg), &
                            err_stat )
    END SUBROUTINE WriteGAtts_CleanUp

  END FUNCTION WriteGAtts

  ! Function to read the global attributes from a Solar data file.

  FUNCTION ReadGAtts( &
    Filename  , &  ! Input
    FileId    , &  ! Input
    Release   , &  ! Optional output
    Version   , &  ! Optional output
    Title     , &  ! Optional output
    History   , &  ! Optional output
    Comment   , &  ! Optional output
    Source    , &  ! Optional output
    References) &  ! Optional output
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER     ,           INTENT(IN)  :: FileId
    INTEGER     , OPTIONAL, INTENT(OUT) :: Release
    INTEGER     , OPTIONAL, INTENT(OUT) :: Version
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: History
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Source
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: References
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_ReadGAtts(netCDF)'
    ! Local variables
    CHARACTER(ML)   :: msg
    CHARACTER(256)  :: gattname
    CHARACTER(5000) :: gattstring
    INTEGER :: nf90_status

    ! Set up
    err_stat = SUCCESS

    ! The global attributes
    ! ...The Release
    IF ( PRESENT(Release) ) THEN
      gattname = RELEASE_GATTNAME
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),Release )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The Version
    IF ( PRESENT(Version) ) THEN
      gattname = VERSION_GATTNAME
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),Version )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
    END IF
    ! ...The Title
    IF ( PRESENT(Title) ) THEN
      gattname = TITLE_GATTNAME; gattstring = ''
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),gattstring )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
      CALL StrClean( gattstring )
      Title = gattstring(1:MIN(LEN(Title), LEN_TRIM(gattstring)))
    END IF
    ! ...The History
    IF ( PRESENT(History) ) THEN
      gattname = HISTORY_GATTNAME; gattstring = ''
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),gattstring )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
      CALL StrClean( gattstring )
      History = gattstring(1:MIN(LEN(History), LEN_TRIM(gattstring)))
    END IF
    ! ...The Comment
    IF ( PRESENT(Comment) ) THEN
      gattname = COMMENT_GATTNAME; gattstring = ''
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),gattstring )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
      CALL StrClean( gattstring )
      Comment = gattstring(1:MIN(LEN(Comment), LEN_TRIM(gattstring)))
    END IF
    ! ...The Source
    IF ( PRESENT(Source) ) THEN
      gattname = SOURCE_GATTNAME; gattstring = ''
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),gattstring )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
      CALL StrClean( gattstring )
      Source = gattstring(1:MIN(LEN(Source), LEN_TRIM(gattstring)))
    END IF
    ! ...The References
    IF ( PRESENT(References) ) THEN
      gattname = REFERENCES_GATTNAME; gattstring = ''
      nf90_status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(gattname),gattstring )
      IF ( nf90_status /= NF90_NOERR ) THEN
        CALL ReadGAtts_Cleanup(); RETURN
      END IF
      CALL StrClean( gattstring )
      References = gattstring(1:MIN(LEN(References), LEN_TRIM(gattstring)))
    END IF

  CONTAINS

    SUBROUTINE ReadGAtts_CleanUp()
      err_stat = FAILURE
      msg = 'Error reading '//TRIM(gattname)//' attribute from '//TRIM(Filename)//' - '// &
            TRIM(NF90_STRERROR( nf90_status ) )
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
    END SUBROUTINE ReadGAtts_CleanUp

  END FUNCTION ReadGAtts

  ! Function to create a Solar file for writing

  FUNCTION CreateFile( &
    Filename     , &  ! Input
    n_Frequencies, &  ! Input
    FileId       , &  ! Output
    Version      , &  ! Optional input
    Title        , &  ! Optional input
    History      , &  ! Optional input
    Comment      , &  ! Optional input
    Source       , &  ! Optional input
    References   ) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER     ,           INTENT(IN)  :: n_Frequencies
    INTEGER     ,           INTENT(OUT) :: FileId
    INTEGER     , OPTIONAL, INTENT(IN)  :: Version
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Title
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: History
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Comment
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Source
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: References
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Solar_CreateFile(netCDF)'
    ! Local variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    INTEGER :: nf90_status
    INTEGER :: n_frequencies_dimid
    INTEGER :: varid
    INTEGER :: put_status(4)

    ! Setup
    err_stat = SUCCESS
    close_file = .FALSE.

    ! Create the data file
    nf90_status = NF90_CREATE( Filename,NF90_CLOBBER,FileId )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error creating '//TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Close the file if any error from here on
    close_file = .TRUE.

    ! Define the dimensions
    ! ...Frequency of the solar and blackbody irradiance spectra
    nf90_status = NF90_DEF_DIM( FileID,FREQUENCY_DIMNAME,n_Frequencies,n_frequencies_dimid )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//FREQUENCY_DIMNAME//' dimension in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF

    ! Write the global attributes
    err_stat = WriteGAtts( &
                 Filename, &
                 FileId  , &
                 Version    = Version   , &
                 Title      = Title     , &
                 History    = History   , &
                 Comment    = Comment   , &
                 Source     = Source    , &
                 References = References  )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error writing global attribute to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF

    ! Define the variables
    ! ...Blackbody_Temperature variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                TB_VARNAME, &
                                TB_TYPE, &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//TB_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,TB_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,TB_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,TB_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,TB_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//TB_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Radius variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                RADIUS_VARNAME, &
                                RADIUS_TYPE, &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//RADIUS_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,RADIUS_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,RADIUS_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,RADIUS_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,RADIUS_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//RADIUS_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Earth_Sun_Distance variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                AU_VARNAME, &
                                AU_TYPE, &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//AU_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,AU_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,AU_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,AU_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,AU_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//AU_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Frequency variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                FREQUENCY_VARNAME, &
                                FREQUENCY_TYPE, &
                                dimIDs=(/n_frequencies_dimid/), &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//FREQUENCY_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,FREQUENCY_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,FREQUENCY_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,FREQUENCY_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,FREQUENCY_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//FREQUENCY_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Irradiance variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                HSOLAR_VARNAME, &
                                HSOLAR_TYPE, &
                                dimIDs=(/n_frequencies_dimid/), &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//HSOLAR_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,HSOLAR_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,HSOLAR_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,HSOLAR_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,HSOLAR_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//HSOLAR_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF
    ! ...Blackbody_Irradiance variable
    nf90_status = NF90_DEF_VAR( FileID, &
                                HTB_VARNAME, &
                                HTB_TYPE, &
                                dimIDs=(/n_frequencies_dimid/), &
                                varID=variD )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error defining '//HTB_VARNAME//' variable in '//&
            TRIM(Filename)//' - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF
    put_status(1) = NF90_PUT_ATT( FileID,varid,LONGNAME_ATTNAME   ,HTB_LONGNAME    )
    put_status(2) = NF90_PUT_ATT( FileID,varid,DESCRIPTION_ATTNAME,HTB_DESCRIPTION )
    put_status(3) = NF90_PUT_ATT( FileID,varid,UNITS_ATTNAME      ,HTB_UNITS       )
    put_status(4) = NF90_PUT_ATT( FileID,varid,FILLVALUE_ATTNAME  ,HTB_FILLVALUE   )
    IF ( ANY(put_status /= NF90_NOERR) ) THEN
      msg = 'Error writing '//HTB_VARNAME//' variable attributes to '//TRIM(Filename)
      CALL Create_Cleanup(); RETURN
    END IF

    ! Take netCDF file out of define mode
    nf90_status = NF90_ENDDEF( FileId )
    IF ( nf90_status /= NF90_NOERR ) THEN
      msg = 'Error taking file '//TRIM(Filename)// &
            ' out of define mode - '//TRIM(NF90_STRERROR( nf90_status ))
      CALL Create_Cleanup(); RETURN
    END IF

  CONTAINS

    SUBROUTINE Create_CleanUp()
      IF ( close_file ) THEN
        nf90_status = NF90_CLOSE( FileID )
        IF ( nf90_status /= NF90_NOERR ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup - '//&
                TRIM(NF90_STRERROR( nf90_status ))
      END IF
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Create_CleanUp

  END FUNCTION CreateFile

END MODULE Solar_IO

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm