module intlightmod

!$$$ module documentation block
!           .      .    .                                       .
! module:   intlightmod    int module for the observation operator for lightning flash rate (LFR)
!
!   prgmmr: k apodaca <karina.apodaca@colostate.edu>
!      org: CSU/CIRA, Data Assimilation Group
!     date: 2016-05-04
!
! abstract: module for the tangent linear (flashrate_TL) and adjoint models (flashrate_AD)
!           of LFR
!
! program history log:
!   2016-05-04  apodaca  - implement TL and AD of the LFR observation operator
!   2018-02-08  apodaca  - replaced ob_type with polymorphic obsNode through type casting
!   2019-03-01  j guo    - encapsulated access to obsdiagNode through obsdiagNode_set()
!
! subroutines included:
!   sub intlight_
!
! variable definitions:
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$ end documentation block
use m_obsNode, only: obsNode
use m_lightNode, only: lightNode
use m_lightNode, only: lightNode_typecast
use m_lightNode, only: lightNode_nextcast
use m_obsdiagNode, only: obsdiagNode_set
implicit none

PRIVATE
PUBLIC intlight

interface intlight; module procedure &
          intlight_
end interface

contains

subroutine intlight_(lighthead,rval,sval)

!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    intlight      TL and subsequent AD of the forward observation operator for LFR
!     prgmmr:    k apodaca
!        org:    CSU/CIRA, Data Assimilation Group
!       date:    2016-05-04
!
! abstract: In this program, the tangent linear and adjoint models of a
!           lightning flash rate observation operator are calculated
!           using a 12-point horizontal grid to calculate finite-difference
!           derivatives and for interpolation in specific quadrants.
!
!           The tangent linear equations represent a way to map
!           the perturbation vectors for the control variables
!           q, qi, qs, qg, t, u, and v.
!
!           Moreover, the adjoint equations map the sensitivity gradient
!           vectors for the control variables (q, qi, qs, qg, t, u, v),
!           thus providing a first order aproximation or linear projection
!           of the sesitivity (impact) of observations.
!
! program history log:
!     2018-01-18 k apodaca revision of AD code
!     2018-08-18 k apodaca add a the TL and AD of second oservation operator for lightning
!                          observations suitable for non-hydrostatic, cloud-resolving models
!                          with additional ice-phase hydrometeor control variables
!
!   input argument list:
!     lighthead   - obs type pointer to obs structure
!     sq          - q  increment in grid space
!     sqi         - qi increment in grid space
!     sqs         - qs increment in grid space
!     sqg         - qg increment in grid space
!     st          - t  increment in grid space
!     su          - u  increment in grid space
!     sv          - v  increment in grid space
!
!   output argument list:
!     rq, rqi, rqs, rqg       - control variabble updates resulting from
!     rt, ru, rv                the assimilation of lightning flash rate
!                               observations
!
!   comments:
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$ end subprogram documentation block

  use kinds,         only: r_kind,i_kind
  use obsmod,        only: lsaveobsens,l_do_adjoint,luse_obsdiag
  use gridmod,       only: nsig
  use gridmod,       only: wrf_mass_regional,regional
  use qcmod,         only: nlnqc_iter,varqc_iter
  use constants,     only: zero,fv,one,half,two,tiny_r_kind,cg_term
  use jfunc,         only: jiter
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use gsi_4dvar,     only: ladtest_obs
  implicit none

! Declare passed variables
  class(obsNode), pointer, intent(in   ) :: lighthead
  type(gsi_bundle),        intent(in   ) :: sval
  type(gsi_bundle),        intent(inout) :: rval

! Declare local variables
  integer(i_kind) k,ier,istatus
  integer(i_kind),dimension(nsig)           :: i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12
  real(r_kind) val,w1,w2,w3,w4
  real(r_kind) cg_light,grad,p0,wnotgross,wgross,pg_light
  real(r_kind),pointer,dimension(:)         :: sq,sqi,sqs,sqg,su,sv,st
  real(r_kind),pointer,dimension(:)         :: rq,rqi,rqs,rqg,ru,rv,rt
  type(lightNode),  pointer             :: lightptr

! Variables for TL and AD of lightning flash rate
  real(r_kind),dimension(1:nsig)            :: z_TL
  real(r_kind),dimension(1:nsig)            :: horiz_adv_TL
  real(r_kind),dimension(1:nsig)            :: vert_adv_TL
  real(r_kind),dimension(1:nsig)            :: w_TL
  real(r_kind)                              :: wmaxi1_TL,wmaxi2_TL,wmaxi3_TL,wmaxi4_TL
  real(r_kind)                              :: flashrate_TL,flashratei1_TL,flashratei2_TL
  real(r_kind)                              :: flashratei3_TL, flashratei4_TL
  real(r_kind)                              :: h1i1_TL,h1i2_TL,h1i3_TL,h1i4_TL
  real(r_kind)                              :: h2i1_TL,h2i2_TL,h2i3_TL,h2i4_TL
  real(r_kind)                              :: totice_colinti1_TL,totice_colinti2_TL
  real(r_kind)                              :: totice_colinti3_TL,totice_colinti4_TL
  real(r_kind)                              :: htot_TL,htoti1_TL,htoti2_TL,htoti3_TL,htoti4_TL
  real(r_kind)                              :: flashrate_AD,flashratei1_AD,flashratei2_AD
  real(r_kind)                              :: flashratei3_AD,flashratei4_AD
  real(r_kind)                              :: wmaxi1_AD,wmaxi2_AD,wmaxi3_AD,wmaxi4_AD
  real(r_kind)                              :: h1i1_AD,h1i2_AD,h1i3_AD,h1i4_AD
  real(r_kind)                              :: h2i1_AD,h2i2_AD,h2i3_AD,h2i4_AD
  real(r_kind)                              :: totice_colinti1_AD,totice_colinti2_AD
  real(r_kind)                              :: totice_colinti3_AD,totice_colinti4_AD
  real(r_kind)                              :: htot_AD,htoti1_AD,htoti2_AD,htoti3_AD,htoti4_AD
  real(r_kind),dimension(1:nsig)            :: z_AD
  real(r_kind),dimension(1:nsig)            :: w_AD
  real(r_kind),dimension(1:nsig)            :: vert_adv_AD,horiz_adv_AD
  real(r_kind),dimension(1:nsig)            :: diffq
  real(r_kind),dimension(1:nsig)            :: difft
  real(r_kind),dimension(1:nsig)            :: diffz
!  wmax variables for lightning flash rate
  real(r_kind)                             :: wmax
  real(r_kind),parameter                   :: k3=0.95_r_kind

!  Output files
!  character :: tlh_file*40

!  If no light data return
  if(.not. associated(lighthead))return
! Retrieve pointers
! Simply return if any pointer not found
  ier=0
  call gsi_bundlegetpointer(sval,'q',sq,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'q',rq,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'qi',sqi,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'qi',rqi,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier
  if(ier/=0)return

  lightptr => lightNode_typecast(lighthead)
  do while (associated(lightptr))

! Load location information into local variables

     w1=lightptr%wij(1)
     w2=lightptr%wij(2)
     w3=lightptr%wij(3)
     w4=lightptr%wij(4)

     do k=1,nsig
        i1(k)=lightptr%ij(1,k)
        i2(k)=lightptr%ij(2,k)
        i3(k)=lightptr%ij(3,k)
        i4(k)=lightptr%ij(4,k)
        i5(k)=lightptr%ij(5,k)
        i6(k)=lightptr%ij(6,k)
        i7(k)=lightptr%ij(7,k)
        i8(k)=lightptr%ij(8,k)
        i9(k)=lightptr%ij(9,k)
        i10(k)=lightptr%ij(10,k)
        i11(k)=lightptr%ij(11,k)
        i12(k)=lightptr%ij(12,k)
     end do

!                .      .    .                                       .

! In the case of lightning observations (e.g. GOES/GLM), the schematic shown below is
! used for bi-linear interpolation of background fields to the location of an observation
! (+) and for the finite-difference derivation method used in the calculation of the TL of
! the observation operator for lightning flash rate. Calculations are done
! at each quadrant, i.e., central, north, south, east, and west.
!
!         i6-------i8
!          |       |
!          |       |
! i10-----i2-------i4-----i12
!  |       |       |       |
!  |       |     + |       |
! i9------i1-------i3-----i11
!          |       |
!          |       |
!         i5-------i7
!

!                .      .    .                                       .

! In the following section, the tangent linear of the lightning flash rate observation
! operator is calculated by being broken into parts.

! Tangent linear of height (z)

     z_TL(:)=zero
     horiz_adv_TL(:)=zero

     do k=2,nsig-1

        z_TL(i1(1))=lightptr%jac_z0i1
        z_TL(i2(1))=lightptr%jac_z0i2
        z_TL(i3(1))=lightptr%jac_z0i3
        z_TL(i4(1))=lightptr%jac_z0i4
        z_TL(i5(1))=lightptr%jac_z0i5
        z_TL(i6(1))=lightptr%jac_z0i6
        z_TL(i7(1))=lightptr%jac_z0i7
        z_TL(i8(1))=lightptr%jac_z0i8
        z_TL(i9(1))=lightptr%jac_z0i9
        z_TL(i10(1))=lightptr%jac_z0i10
        z_TL(i11(1))=lightptr%jac_z0i11
        z_TL(i12(1))=lightptr%jac_z0i12

        z_TL(i1(k))=z_TL(i1(k-1))+lightptr%jac_vertti1(k)*st(i1(k))          &
                   +lightptr%jac_vertqi1(k)*sq(i1(k))

        z_TL(i2(k))=z_TL(i2(k-1))+lightptr%jac_vertti2(k)*st(i2(k))          &
                   +lightptr%jac_vertqi2(k)*sq(i2(k))

        z_TL(i3(k))=z_TL(i3(k-1))+lightptr%jac_vertti3(k)*st(i3(k))          &
                   +lightptr%jac_vertqi3(k)*sq(i3(k))

        z_TL(i4(k))=z_TL(i4(k-1))+lightptr%jac_vertti4(k)*st(i4(k))          &
                   +lightptr%jac_vertqi4(k)*sq(i4(k))

        z_TL(i5(k))=z_TL(i5(k-1))+lightptr%jac_vertti5(k)*st(i5(k))          &
                   +lightptr%jac_vertqi5(k)*sq(i5(k))

        z_TL(i6(k))=z_TL(i6(k-1))+lightptr%jac_vertti6(k)*st(i6(k))          &
                   +lightptr%jac_vertqi6(k)*sq(i6(k))

        z_TL(i7(k))=z_TL(i7(k-1))+lightptr%jac_vertti7(k)*st(i7(k))          &
                   +lightptr%jac_vertqi7(k)*sq(i7(k))

        z_TL(i8(k))=z_TL(i8(k-1))+lightptr%jac_vertti8(k)*st(i8(k))          &
                   +lightptr%jac_vertqi8(k)*sq(i8(k))

        z_TL(i9(k))=z_TL(i9(k-1))+lightptr%jac_vertti9(k)*st(i9(k))          &
                   +lightptr%jac_vertqi9(k)*sq(i9(k))

        z_TL(i10(k))=z_TL(i10(k-1))+lightptr%jac_vertti10(k)*st(i10(k))      &
                    +lightptr%jac_vertqi10(k)*sq(i10(k))

        z_TL(i11(k))=z_TL(i11(k-1))+lightptr%jac_vertti11(k)*st(i11(k))      &
                  +lightptr%jac_vertqi11(k)*sq(i11(k))

        z_TL(i12(k))=z_TL(i12(k-1))+lightptr%jac_vertti12(k)*st(i12(k))      &
                  +lightptr%jac_vertqi12(k)*sq(i12(k))

! Tangent Linear of the Horizontal Advection Section

        horiz_adv_TL(i1(k))=lightptr%jac_zdxi1(k)*su(i1(k))                  &
                           +lightptr%jac_zdyi1(k)*sv(i1(k))                  &
                           +lightptr%jac_udxi1(k)*(z_TL(i3(k))-z_TL(i9(k)))  &
                           +lightptr%jac_vdyi1(k)*(z_TL(i2(k))-z_TL(i5(k)))
        horiz_adv_TL(i2(k))=lightptr%jac_zdxi2(k)*su(i2(k))                  &
                           +lightptr%jac_zdyi2(k)*sv(i2(k))                  &
                           +lightptr%jac_udxi2(k)*(z_TL(i4(k))-z_TL(i10(k))) &
                           +lightptr%jac_vdyi2(k)*(z_TL(i6(k))-z_TL(i1 (k)))

        horiz_adv_TL(i3(k))=lightptr%jac_zdxi3(k)*su(i3(k))                  &
                           +lightptr%jac_zdyi3(k)*sv(i3(k))                  &
                           +lightptr%jac_udxi3(k)*(z_TL(i11(k))-z_TL(i1(k))) &
                           +lightptr%jac_vdyi3(k)*(z_TL(i4 (k))-z_TL(i7(k)))

        horiz_adv_TL(i4(k))=lightptr%jac_zdxi4(k)*su(i4(k))                  &
                           +lightptr%jac_zdyi4(k)*sv(i4(k))                  &
                           +lightptr%jac_udxi4(k)*(z_TL(i12(k))-z_TL(i2(k))) &
                           +lightptr%jac_vdyi4(k)*(z_TL(i8 (k))-z_TL(i3(k)))

     enddo ! do k=2,nsig-1

! Tangent Linear of the Vertical Advection Section

     vert_adv_TL(:)=zero
     w_TL(:)=zero

     do k=1,nsig-1

        vert_adv_TL(i1(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti1(k)*    &
                          (((one+fv*lightptr%jac_qi1(k))*st(i1(k)))           &
                          +(lightptr%jac_ti1(k)*fv*sq(i1(k))))

        vert_adv_TL(i2(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti2(k)*    &
                          (((one+fv*lightptr%jac_qi2(k))*st(i2(k)))           &
                          +(lightptr%jac_ti2(k)*fv*sq(i2(k))))

        vert_adv_TL(i3(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti3(k)*    &
                          (((one+fv*lightptr%jac_qi3(k))*st(i3(k)))           &
                          +(lightptr%jac_ti3(k)*fv*sq(i3(k))))

        vert_adv_TL(i4(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti4(k)*    &
                          (((one+fv*lightptr%jac_qi4(k))*st(i4(k)))           &
                          +(lightptr%jac_ti4(k)*fv*sq(i4(k))))

! Tangent Linear of Vertical Velocity

        w_TL(i1(k))=horiz_adv_TL(i1(k))+vert_adv_TL(i1(k))
        w_TL(i2(k))=horiz_adv_TL(i2(k))+vert_adv_TL(i2(k))
        w_TL(i3(k))=horiz_adv_TL(i3(k))+vert_adv_TL(i3(k))
        w_TL(i4(k))=horiz_adv_TL(i4(k))+vert_adv_TL(i4(k))

     enddo !do k=1,nsig-1

!                .      .    .                                       .
! Tangent Linear of lightning flash rate

!                .      .    .                                       .
! Regional

     if (regional) then

!-- WRF-ARW

        if (wrf_mass_regional) then

! Tangent linear - Lightning flash rate as a function of
! vertical graupel flux within the mixed-phase region
! (-15 deg C)

           if (lightptr%kboti1 > zero) then
               h1i1_TL=lightptr%jac_qgmai1(lightptr%kboti1)*sqg(i1(lightptr%kboti1))+&
                       lightptr%jac_qgmbi1(lightptr%kboti1)*&
                       (half*(w_TL(i1(lightptr%kboti1))+w_TL(i1(lightptr%kboti1+1))))
               h1i1_TL=h1i1_TL/(abs(h1i1_TL))
           else
               h1i1_TL=zero
           endif

           if (lightptr%kboti2 > zero) then
               h1i2_TL=lightptr%jac_qgmai2(lightptr%kboti2)*sqg(i2(lightptr%kboti2))+&
                       lightptr%jac_qgmbi2(lightptr%kboti2)*&
                       (half*(w_TL(i2(lightptr%kboti2))+w_TL(i2(lightptr%kboti2+1))))
               h1i2_TL=h1i2_TL/(abs(h1i2_TL))
           else
               h1i2_TL=zero
           endif

           if (lightptr%kboti3 > zero) then
               h1i3_TL=lightptr%jac_qgmai3(lightptr%kboti3)*sqg(i3(lightptr%kboti3))+&
                       lightptr%jac_qgmbi3(lightptr%kboti3)*&
                       (half*(w_TL(i3(lightptr%kboti3))+w_TL(i3(lightptr%kboti3+1))))
               h1i3_TL=h1i3_TL/(abs(h1i3_TL))
           else
               h1i3_TL=zero
           endif

           if (lightptr%kboti4 > zero) then
               h1i4_TL=lightptr%jac_qgmai4(lightptr%kboti4)*sqg(i4(lightptr%kboti4))+&
                       lightptr%jac_qgmbi4(lightptr%kboti4)*&
                       (half*(w_TL(i4(lightptr%kboti4))+w_TL(i4(lightptr%kboti4+1))))
               h1i4_TL=h1i4_TL/(abs(h1i4_TL))
           else
               h1i4_TL=zero
           endif

! Tangent Linear - Lightning flash rate as a function of total column-integrated
! ice-phase hydrometeors

           totice_colinti1_TL=zero
           totice_colinti2_TL=zero
           totice_colinti3_TL=zero
           totice_colinti4_TL=zero

           do k=1,nsig-1

               totice_colinti1_TL = totice_colinti1_TL+lightptr%jac_icei1(k) * &
                                   (sqi(i1(k))+sqs(i1(k))+sqg(i1(k)))+&
                                    lightptr%jac_zicei1(k)*z_TL(i1(k))

               totice_colinti2_TL = totice_colinti2_TL+lightptr%jac_icei2(k) * &
                                   (sqi(i2(k))+sqs(i2(k))+sqg(i2(k)))+&
                                    lightptr%jac_zicei2(k)*z_TL(i2(k))

               totice_colinti3_TL = totice_colinti3_TL+lightptr%jac_icei3(k) * &
                                   (sqi(i3(k))+sqs(i3(k))+sqg(i3(k)))+&
                                    lightptr%jac_zicei3(k)*z_TL(i3(k))

               totice_colinti4_TL = totice_colinti4_TL+lightptr%jac_icei4(k) * &
                                   (sqi(i4(k))+sqs(i4(k))+sqg(i4(k)))+&
                                    lightptr%jac_zicei4(k)*z_TL(i4(k))

           enddo !do k=1,nsig-1

           h2i1_TL=(1-k3)*totice_colinti1_TL
           h2i2_TL=(1-k3)*totice_colinti2_TL
           h2i3_TL=(1-k3)*totice_colinti3_TL
           h2i4_TL=(1-k3)*totice_colinti4_TL

           htoti1_TL= h1i1_TL+h2i1_TL
           htoti2_TL= h1i2_TL+h2i2_TL
           htoti3_TL= h1i3_TL+h2i3_TL
           htoti4_TL= h1i4_TL+h2i4_TL

!  Interpolation of lightning flash rate to observation location (2D field)
!  Forward Model

           htot_TL = (w1*htoti1_TL + w2*htoti2_TL + &
                      w3*htoti3_TL + w4*htoti4_TL)
           val = htot_TL

        endif ! wrf_mass_regional

     endif !if (regional) then

!                .      .    .                                       .
! Global

     if (.not. regional) then ! Global

! Cloud Mask

! If clouds are present, find the maximum value of vertical velocity
! (wmax_TL) at four points sorounding an observation (+)
! and amongst all vertical levels, otherwise set wmax_TL to zero.

        wmaxi1_TL=zero
        wmaxi2_TL=zero
        wmaxi3_TL=zero
        wmaxi4_TL=zero

        if (lightptr%jac_wmaxflagi1) then
            wmax=-1.e+10_r_kind
            do k=1,nsig-1
               if (w_TL(i1(k)) > wmax) then
                   lightptr%jac_kverti1=k
                   wmaxi1_TL=w_TL(i1(lightptr%jac_kverti1))
               endif
               if (wmaxi1_TL < zero) then
                   wmaxi1_TL=zero
               endif
            enddo ! k loop
        endif

        if (lightptr%jac_wmaxflagi2) then
           wmax=-1.e+10_r_kind
           do k=1,nsig-1
              if (w_TL(i2(k)) > wmax) then
                 lightptr%jac_kverti2=k
                 wmaxi2_TL=w_TL(i2(lightptr%jac_kverti2))
              endif
              if (wmaxi2_TL <  zero) then
                 wmaxi2_TL=zero
              endif
           enddo ! k loop
        endif

        if (lightptr%jac_wmaxflagi3) then
            wmax=-1.e+10_r_kind
            do k=1,nsig-1
               if (w_TL(i3(k)) > wmax) then
                   lightptr%jac_kverti3=k
                   wmaxi3_TL=w_TL(i3(lightptr%jac_kverti3))
               endif
               if (wmaxi3_TL <  zero) then
                   wmaxi3_TL=zero
               endif
            enddo ! k loop
        endif

        if (lightptr%jac_wmaxflagi4) then
            wmax=-1.e+10_r_kind
            do k=1,nsig-1
               if (w_TL(i4(k)) > wmax) then
                   lightptr%jac_kverti4=k
                   wmaxi4_TL=w_TL(i4(lightptr%jac_kverti4))
               endif
               if (wmaxi4_TL < zero) then
                   wmaxi4_TL=zero
               endif
            enddo ! k loop
        endif

! Tangent Linear of Lightning Flash Rate

        flashratei1_TL=lightptr%jac_fratei1*wmaxi1_TL
        flashratei2_TL=lightptr%jac_fratei1*wmaxi2_TL
        flashratei3_TL=lightptr%jac_fratei1*wmaxi3_TL
        flashratei4_TL=lightptr%jac_fratei1*wmaxi4_TL

!  Interpolation of lightning flash rate to observation location (2D field)
!  Forward Model

        flashrate_TL = (w1*flashratei1_TL + w2*flashratei2_TL + &
                     w3*flashratei3_TL + w4*flashratei4_TL)
        val =  flashrate_TL

     end if ! global block

     if (luse_obsdiag)then
         if (lsaveobsens) then
            grad = val*lightptr%raterr2*lightptr%err2
            !-- lightptr%diags%obssen(jiter) = grad
            call obsdiagNode_set(lightptr%diags,jiter=jiter,obssen=grad)
         else
            !-- if (lightptr%luse) lightptr%diags%tldepart(jiter)=val
            if (lightptr%luse) call obsdiagNode_set(lightptr%diags,jiter=jiter,tldepart=val)
         endif
      end if

!                .      .    .                                       .

! Adjoint test

     if (l_do_adjoint) then
! Difference from observation
        if (.not. lsaveobsens) then
        if (.not. ladtest_obs)  val=val-lightptr%res

!       needed for gradient of nonlinear qc operator
           if (nlnqc_iter .and. lightptr%pg > tiny_r_kind .and.  &
                                lightptr%b  > tiny_r_kind) then
              pg_light=lightptr%pg*varqc_iter
              cg_light=cg_term/lightptr%b
              wnotgross= one-pg_light
              wgross = pg_light*cg_light/wnotgross
              p0   = wgross/(wgross+exp(-half*lightptr%err2*val**2))
              val = val*(one-p0)
           endif

           if( ladtest_obs) then
              grad = val
           else
              grad = val*lightptr%raterr2*lightptr%err2
           end if
         endif

!                .      .    .                                       .

! Adjoint of the Lightning Flash Rate Observation Operator

!                .      .    .                                       .
! Variable initialization

            z_AD(:)=zero
            w_AD(:)=zero

! Regional

     if (regional) then

!-- WRF-ARW

        if (wrf_mass_regional) then

            htot_AD=grad

! Adjoint - Total lightning flash rate

            htoti1_AD=htoti1_AD+w1*htot_AD
            htoti2_AD=htoti2_AD+w1*htot_AD
            htoti3_AD=htoti3_AD+w1*htot_AD
            htoti4_AD=htoti4_AD+w1*htot_AD

            h1i1_AD=h1i1_AD+htoti1_AD
            h2i1_AD=h2i1_AD+htoti1_AD

            h1i2_AD=h1i2_AD+htoti2_AD
            h2i2_AD=h2i2_AD+htoti2_AD

            h1i3_AD=h1i3_AD+htoti3_AD
            h2i3_AD=h2i3_AD+htoti3_AD

            h1i4_AD=h1i4_AD+htoti4_AD
            h2i4_AD=h2i4_AD+htoti4_AD

            totice_colinti1_AD=totice_colinti1_AD+(1-k3)*h2i1_AD
            totice_colinti2_AD=totice_colinti2_AD+(1-k3)*h2i2_AD
            totice_colinti3_AD=totice_colinti3_AD+(1-k3)*h2i3_AD
            totice_colinti4_AD=totice_colinti4_AD+(1-k3)*h2i4_AD

! Adjoint - Lightning flash rate as a function of total column-integrated
! ice-phase hydrometeors

            do k=nsig-1,1,-1

               z_AD(i1(k))=z_AD(i1(k))+lightptr%jac_zicei1(k)*totice_colinti1_AD
               rqi(i1(k))=rqi(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD
               rqs(i1(k))=rqs(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD
               rqg(i1(k))=rqg(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD
               totice_colinti1_AD=two*totice_colinti1_AD

               z_AD(i2(k))=z_AD(i2(k))+lightptr%jac_zicei2(k)*totice_colinti2_AD
               rqi(i2(k))=rqi(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD
               rqs(i2(k))=rqs(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD
               rqg(i2(k))=rqg(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD
               totice_colinti2_AD=two*totice_colinti2_AD

               z_AD(i3(k))=z_AD(i3(k))+lightptr%jac_zicei3(k)*totice_colinti3_AD
               rqi(i3(k))=rqi(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD
               rqs(i3(k))=rqs(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD
               rqg(i3(k))=rqg(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD
               totice_colinti3_AD=two*totice_colinti3_AD

               z_AD(i4(k))=z_AD(i4(k))+lightptr%jac_zicei4(k)*totice_colinti4_AD
               rqi(i4(k))=rqi(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD
               rqs(i4(k))=rqs(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD
               rqg(i4(k))=rqg(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD
               totice_colinti4_AD=two*totice_colinti4_AD

! Adjoint - Lightning flash rate as a function of
! vertical graupel flux within the mixed-phase region
! (-15 deg C)

               if (lightptr%kboti1 > zero) then
                   h1i1_AD=h1i1_AD+(h1i1_AD/abs(h1i1_AD))
                   rqg(i1(lightptr%kboti1))=rqg(i1(lightptr%kboti1))+&
                                            lightptr%jac_qgmai1(lightptr%kboti1)*h1i1_AD
                   w_AD(i1(lightptr%kboti1))=w_AD(i1(lightptr%kboti1))+&
                                             half*lightptr%jac_qgmbi1(lightptr%kboti1)*h1i1_AD
                   w_AD(i1(lightptr%kboti1+1))=w_AD(i1(lightptr%kboti1+1))+&
                                               half*lightptr%jac_qgmbi1(lightptr%kboti1)*h1i1_AD
               else
                   h1i1_AD=zero
                   rqg(i1(lightptr%kboti1))=zero
                   w_AD(i1(lightptr%kboti1))=zero
                   w_AD(i1(lightptr%kboti1+1))=zero
               endif

               if (lightptr%kboti2 > zero) then
                   h1i2_AD=h1i2_AD+(h1i2_AD/abs(h1i2_AD))
                   rqg(i2(lightptr%kboti2))=rqg(i2(lightptr%kboti2))+&
                                            lightptr%jac_qgmai2(lightptr%kboti2)*h1i2_AD
                   w_AD(i2(lightptr%kboti2))=w_AD(i2(lightptr%kboti2))+&
                                             half*lightptr%jac_qgmbi2(lightptr%kboti2)*h1i2_AD
                   w_AD(i2(lightptr%kboti2+1))=w_AD(i2(lightptr%kboti2+1))+&
                                               half*lightptr%jac_qgmbi2(lightptr%kboti2)*h1i2_AD
               else
                   h1i2_AD=zero
                   rqg(i2(lightptr%kboti2))=zero
                   w_AD(i2(lightptr%kboti2+1))=zero
               endif

               if (lightptr%kboti3 > zero) then
                   h1i3_AD=h1i3_AD+(h1i3_AD/abs(h1i3_AD))
                   rqg(i3(lightptr%kboti3))=rqg(i3(lightptr%kboti3))+&
                                            lightptr%jac_qgmai3(lightptr%kboti3)*h1i3_AD
                   w_AD(i3(lightptr%kboti3))=w_AD(i3(lightptr%kboti3))+&
                                             half*lightptr%jac_qgmbi3(lightptr%kboti3)*h1i3_AD
                   w_AD(i3(lightptr%kboti3+1))=w_AD(i3(lightptr%kboti3+1))+&
                                               half*lightptr%jac_qgmbi3(lightptr%kboti3)*h1i3_AD
               else
                   h1i3_AD=zero
                   rqg(i3(lightptr%kboti3))=zero
                   w_AD(i3(lightptr%kboti3+1))=zero
               endif

               if (lightptr%kboti4 > zero) then
                   h1i4_AD=h1i4_AD+(h1i4_AD/abs(h1i4_AD))
                   rqg(i4(lightptr%kboti4))=rqg(i4(lightptr%kboti4))+&
                                            lightptr%jac_qgmai4(lightptr%kboti4)*h1i4_AD
                   w_AD(i4(lightptr%kboti4))=w_AD(i4(lightptr%kboti4))+&
                                             half*lightptr%jac_qgmbi4(lightptr%kboti4)*h1i4_AD
                   w_AD(i4(lightptr%kboti4+1))=w_AD(i4(lightptr%kboti4+1))+&
                                               half*lightptr%jac_qgmbi4(lightptr%kboti4)*h1i4_AD
               else
                   h1i4_AD=zero
                   rqg(i4(lightptr%kboti4))=zero
                   w_AD(i4(lightptr%kboti4+1))=zero
               endif

            enddo !do k=nsig-1,1,-1

        endif ! wrf_mass_regional

     endif !if (regional) then

!                .      .    .                                       .
! Global

     if (.not. regional) then

            flashrate_AD=grad

            flashratei1_AD=flashratei1_AD+w1*flashrate_AD
            flashratei2_AD=flashratei2_AD+w2*flashrate_AD
            flashratei3_AD=flashratei3_AD+w3*flashrate_AD
            flashratei4_AD=flashratei4_AD+w4*flashrate_AD

! Adjoint of Maximum Vertical Velocity

            wmaxi1_AD=wmaxi1_AD+lightptr%jac_fratei1*flashratei1_AD
            wmaxi2_AD=wmaxi2_AD+lightptr%jac_fratei2*flashratei2_AD
            wmaxi3_AD=wmaxi3_AD+lightptr%jac_fratei3*flashratei3_AD
            wmaxi4_AD=wmaxi3_AD+lightptr%jac_fratei4*flashratei4_AD

            if (lightptr%jac_wmaxflagi1) then
                wmax=-1.e+10_r_kind
                do k=nsig-1,1,-1
                   if (wmaxi1_AD <  zero) then
                       wmaxi1_AD=zero
                   endif
                   if (wmaxi1_AD > wmax) then
                       lightptr%jac_kverti1=k
                       w_AD(i1(lightptr%jac_kverti1))=w_AD(i1(lightptr%jac_kverti1))+wmaxi1_AD
                   endif
                enddo
            endif

            if (lightptr%jac_wmaxflagi2) then
                wmax=-1.e+10_r_kind
                do k=nsig-1,1,-1
                   if (wmaxi2_AD <  zero) then
                       wmaxi2_AD=zero
                   endif
                   if (wmaxi2_AD > wmax) then
                       lightptr%jac_kverti2=k
                       w_AD(i2(lightptr%jac_kverti2))=w_AD(i2(lightptr%jac_kverti2))+wmaxi2_AD
                   endif
                enddo
            endif

            if (lightptr%jac_wmaxflagi3) then
                wmax=-1.e+10_r_kind
                do k=nsig-1,1,-1
                   if (wmaxi3_AD <  zero) then
                       wmaxi3_AD=zero
                   endif
                   if (wmaxi3_AD > wmax) then
                       lightptr%jac_kverti3=k
                       w_AD(i3(lightptr%jac_kverti3))=w_AD(i3(lightptr%jac_kverti3))+wmaxi3_AD
                   endif
                enddo
            endif

            if (lightptr%jac_wmaxflagi4) then
                wmax=-1.e+10_r_kind
                do k=nsig-1,1,-1
                   if (wmaxi4_AD <  zero) then
                       wmaxi4_AD=zero
                   endif
                   if (wmaxi4_AD > wmax) then
                       lightptr%jac_kverti4=k
                       w_AD(i4(lightptr%jac_kverti4))=w_AD(i4(lightptr%jac_kverti4))+wmaxi4_AD
                   endif
                enddo
            endif

     endif !  end global block
!                .      .    .                                       .

! Adjoint of Vertical Velocity (from Vertical and Horizontal Advection)

     vert_adv_AD(:)=zero

     do k=nsig-1,1,-1

        vert_adv_AD(i4(k))=vert_adv_AD(i4(k))+w_AD(i4(k))
        vert_adv_AD(i3(k))=vert_adv_AD(i3(k))+w_AD(i3(k))
        vert_adv_AD(i2(k))=vert_adv_AD(i2(k))+w_AD(i2(k))
        vert_adv_AD(i1(k))=vert_adv_AD(i1(k))+w_AD(i1(k))

     enddo

     horiz_adv_AD(:)=zero

     do k=nsig-1,2,-1

        horiz_adv_AD(i4(k))=horiz_adv_AD(i4(k))+w_AD(i4(k))
        horiz_adv_AD(i4(k))=horiz_adv_AD(i3(k))+w_AD(i3(k))
        horiz_adv_AD(i2(k))=horiz_adv_AD(i2(k))+w_AD(i2(k))
        horiz_adv_AD(i1(k))=horiz_adv_AD(i1(k))+w_AD(i1(k))

     enddo

! Adjoint of q and t from the Vertical Advection Section

     diffq(:)=zero
     difft(:)=zero

     do k=nsig-1,1,-1

        diffq(i1(k))=-(lightptr%jac_ti1(k)*fv*lightptr%jac_vert(K)        &
                     *lightptr%jac_sigdoti1(k))*vert_adv_AD(i1(k))
        difft(i1(k))=-((one+fv*lightptr%jac_qi1(k))*lightptr%jac_vert(k)  &
                     *lightptr%jac_sigdoti1(k))*vert_adv_AD(i1(k))
        diffq(i2(k))=-(lightptr%jac_ti2(k)*fv*lightptr%jac_vert(k)        &
                     *lightptr%jac_sigdoti2(k))*vert_adv_AD(i2(k))
        difft(i2(k))=-((one+fv*lightptr%jac_qi2(k))*lightptr%jac_vert(k)  &
                     *lightptr%jac_sigdoti2(k))*vert_adv_AD(i2(k))
        diffq(i3(k))=-(lightptr%jac_ti3(k)*fv*lightptr%jac_vert(k)        &
                     *lightptr%jac_sigdoti3(k))*vert_adv_AD(i3(k))
        difft(i3(k))=-((one+fv*lightptr%jac_qi3(k))*lightptr%jac_vert(k)  &
                     *lightptr%jac_sigdoti3(k))*vert_adv_AD(i3(k))
        diffq(i4(k))=-(lightptr%jac_ti4(k)*fv*lightptr%jac_vert(k)        &
                     *lightptr%jac_sigdoti4(k))*vert_adv_AD(i4(k))
        difft(i4(k))=-((one+fv*lightptr%jac_qi4(k))*lightptr%jac_vert(k)  &
                     *lightptr%jac_sigdoti4(k))*vert_adv_AD(i4(k))

        rq(i1(k))=rq(i1(k))+diffq(i1(k))

        rt(i1(k))=rt(i1(k))+difft(i1(k))

        rq(i2(k))=rq(i2(k))+diffq(i2(k))

        rq(i3(k))=rq(i3(k))+diffq(i3(k))

        rt(i3(k))=rt(i3(k))+difft(i3(k))

        rq(i4(k))=rq(i4(k))+diffq(i4(k))

        rt(i4(k))=rt(i4(k))+difft(i4(k))

     enddo

! Adjoint of z, u, and v from the Horizontal Advection Section

     diffz(:)=zero
     z_AD(:)=zero

     do k=nsig-1,2,-1

        diffz(i5(k))=-lightptr%jac_vdyi1(k)*horiz_adv_AD(i1(k))
        diffz(i9(k))=-lightptr%jac_udxi1(k)*horiz_adv_AD(i1(k))

        z_AD(i5(k))=z_AD(i5(k))+diffz(i5(k))
        z_AD(i2(k))=z_AD(i2(k))+(lightptr%jac_vdyi1(k)*horiz_adv_AD(i1(k)))
        z_AD(i9(k))=z_AD(i9(k))+(diffz(i9(k)))
        z_AD(i3(k))=z_AD(i3(k))+(lightptr%jac_udxi1(k)*horiz_adv_AD(i1(k)))

        rv(i1(k))=rv(i1(k))+(lightptr%jac_zdyi1(k)*horiz_adv_AD(i1(k)))
        ru(i1(k))=ru(i1(k))+(lightptr%jac_zdxi1(k)*horiz_adv_AD(i1(k)))

        diffz(i1(k)) =-lightptr%jac_vdyi2(k)*horiz_adv_AD(i2(k))
        diffz(i10(k))=-lightptr%jac_udxi2(k)*horiz_adv_AD(i2(k))

        z_AD(i1(k))=z_AD(i1(k))+(diffz(i1(k)))
        z_AD(i6(k))=z_AD(i6(k))+(lightptr%jac_vdyi2(k)*horiz_adv_AD(i2(k)))
        z_AD(i10(k))=z_AD(i10(k))+(diffz(i10(k)))
        z_AD(i4(k))=z_AD(i4(k))+(lightptr%jac_udxi2(k)*horiz_adv_AD(i2(k)))
        rv(i2(k))=rv(i2(k))+(lightptr%jac_zdyi2(k)*horiz_adv_AD(i2(k)))
        ru(i2(k))=ru(i2(k))+(lightptr%jac_zdxi2(k)*horiz_adv_AD(i2(k)))

        diffz(i7(k))= -lightptr%jac_vdyi3(k)*horiz_adv_AD(i3(k))
        diffz(i1(k))= -lightptr%jac_udxi3(k)*horiz_adv_AD(i3(k))

        z_AD(i7(k)) =  z_AD(i7(k))+diffz(i7(k))
        z_AD(i4(k)) =  z_AD(i4(k))+(lightptr%jac_vdyi3(k)*horiz_adv_AD(i3(k)))
        z_AD(i1(k)) =  z_AD(i1(k))+diffz(i1(k))
        z_AD(i11(k))=  z_AD(i11(k))+(lightptr%jac_udxi3(k)*horiz_adv_AD(i3(k)))
        rv(i3(k)) =  rv(i3(k))+(lightptr%jac_zdyi3(k)*horiz_adv_AD(i3(k)))
        ru(i3(k)) =  ru(i3(k))+(lightptr%jac_zdxi3(k)*horiz_adv_AD(i3(k)))

        diffz(i3(k))=-lightptr%jac_vdyi4(k)*horiz_adv_AD(i4(k))
        diffz(i2(k))=-z_TL(i2(k))-lightptr%jac_udxi4(k)*horiz_adv_AD(i4(k))

        z_AD(i3(k)) =  z_AD(i3(k))+diffz(i3(k))
        z_AD(i8(k)) =  z_AD(i8(k))+(lightptr%jac_vdyi4(k)*horiz_adv_AD(i4(k)))
        z_AD(i2(k)) = z_TL(i2(k))+diffz(i2(k))
        z_AD(i12(k))= z_AD(i12(k))+(lightptr%jac_udxi4(k)*horiz_adv_AD(i4(k)))
        rv(i4(k)) = rv(i4(k))+(lightptr%jac_zdyi4(k)*horiz_adv_AD(i4(k)))
        ru(i4(k)) = ru(i4(k))+(lightptr%jac_zdxi4(k)*horiz_adv_AD(i4(k)))

     enddo

! Adjoint of q and t from the Calculation of Height (z)

     do k=nsig-1,2,-1

        rq(i1(k))=rq(i1(k))+lightptr%jac_vertqi1(k)*z_AD(i1(k))
        rt(i1(k))=rt(i1(k))+lightptr%jac_vertti1(k)*z_AD(i1(k))
        z_AD(i1(k-1))=z_AD(i1(k-1))+z_AD(i1(k))
        z_AD(i1(k))=zero

        rq(i2(k))=rq(i2(k))+lightptr%jac_vertqi2(k)*z_AD(i2(k))
        rt(i2(k))=rt(i2(k))+lightptr%jac_vertti12(k)*z_AD(i2(k))
        z_AD(i2(k-1))=z_AD(i2(k-1))+z_AD(i2(k))
        z_AD(i2(k))=zero

        rq(i3(k))=rq(i3(k))+lightptr%jac_vertqi3(k)*z_AD(i3(k))
        rt(i3(k))=rt(i3(k))+lightptr%jac_vertti3(k)*z_AD(i3(k))
        z_AD(i3(k-1))=z_AD(i3(k-1))+z_AD(i3(k))
        z_AD(i3(k))=zero

        rq(i4(k))=rq(i4(k))+lightptr%jac_vertqi4(k)*z_AD(i4(k))
        rt(i4(k))=rt(i4(k))+lightptr%jac_vertti4(k)*z_AD(i4(k))
        z_AD(i4(k-1))=z_AD(i4(k-1))+z_AD(i4(k))
        z_AD(i4(k))=zero

        rq(i5(k))=rq(i5(k))+lightptr%jac_vertqi5(k)*z_AD(i5(k))
        rt(i5(k))=rt(i5(k))+lightptr%jac_vertti5(k)*z_AD(i5(k))
        z_AD(i5(k-1))=z_AD(i5(k-1))+z_AD(i5(k))
        z_AD(i5(k))=zero

        rq(i6(k))=rq(i6(k))+lightptr%jac_vertqi6(k)*z_AD(i6(k))
        rt(i6(k))=rt(i6(k))+lightptr%jac_vertti6(k)*z_AD(i6(k))
        z_AD(i6(k-1))=z_AD(i6(k-1))+z_AD(i6(k))
        z_AD(i6(k))=zero

        rq(i7(k))=rq(i7(k))+lightptr%jac_vertqi7(k)*z_AD(i7(k))
        rt(i7(k))=rt(i7(k))+lightptr%jac_vertti7(k)*z_AD(i7(k))
        z_AD(i7(k-1))=z_AD(i7(k-1))+z_AD(i7(k))
        z_AD(i7(k))=zero

        rq(i8(k))=rq(i8(k))+lightptr%jac_vertqi8(k)*z_AD(i8(k))
        rt(i8(k))=rt(i8(k))+lightptr%jac_vertti8(k)*z_AD(i8(k))
        z_AD(i8(k-1))=z_AD(i8(k-1))+z_AD(i8(k))
        z_AD(i8(k))=zero

        rq(i9(k))=rq(i9(k))+lightptr%jac_vertqi9(k)*z_AD(i9(k))
        rt(i9(k))=rt(i9(k))+lightptr%jac_vertti9(k)*z_AD(i9(k))
        z_AD(i9(k-1))=z_AD(i9(k-1))+z_AD(i9(k))
        z_AD(i9(k))=zero

        rq(i10(k))=rq(i10(k))+lightptr%jac_vertqi10(k)*z_AD(i10(k))
        rt(i10(k))=rt(i10(k))+lightptr%jac_vertti10(k)*z_AD(i10(k))
        z_AD(i10(k-1))=z_AD(i10(k-1))+z_AD(i10(k))
        z_AD(i10(k))=zero

        rq(i11(k))=rq(i11(k))+lightptr%jac_vertqi11(k)*z_AD(i11(k))
        rt(i11(k))=rt(i11(k))+lightptr%jac_vertti11(k)*z_AD(i11(k))
        z_AD(i11(k-1))=z_AD(i11(k-1))+z_AD(i11(k))
        z_AD(i11(k))=zero

        rq(i12(k))=rq(i12(k))+lightptr%jac_vertqi12(k)*z_AD(i12(k))
        rt(i12(k))=rt(i12(k))+lightptr%jac_vertti12(k)*z_AD(i12(k))
        z_AD(i12(k-1))=z_AD(i12(k-1))+z_AD(i12(k))
        z_AD(i12(k))=zero

     enddo

     endif !Adjoint

     lightptr => lightNode_nextcast(lightptr)

  enddo  ! do while (associated(lightptr))

  return
end subroutine intlight_

end module intlightmod


text:
C Copyright(C) 2009 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE DBIXYZ (NDB, OPTION, NDIM, NUMNP, XN, YN, ZN, *)
C=======================================================================
C$Id: dbixyz.f,v 1.2 2009/03/25 12:46:01 gdsjaar Exp $
C$Log: dbixyz.f,v $
CRevision 1.2  2009/03/25 12:46:01  gdsjaar
CAdd copyright and license notice to all files.
C
CRevision 1.1.1.1  1990/08/14 16:13:14  gdsjaar
CTesting
C
c Revision 1.1  90/08/14  16:13:12  gdsjaar
c Initial revision
c
c Revision 1.1  90/08/09  13:39:14  gdsjaar
c Initial revision
c

C   --*** DBIXYZ *** (EXOLIB) Read database coordinates
C   --   Written by Amy Gilkey - revised 10/14/87
C   --
C   --DBIXYZ reads the coordinate array from the database.  An error
C   --message is displayed if the end of file is read.
C   --
C   --Parameters:
C   --   NDB - IN - the database file
C   --   OPTION - IN - ' ' to not store, '*' to store all, else store options:
C   --      'C' to store coordinates
C   --   NDIM - IN - the number of coordinates per node
C   --   NUMNP - IN - the number of nodes
C   --   XN, YN, ZN - OUT - the coordinates (if OPTION)
C   --   * - return statement if end of file or read error
C   --
C   --Database must be positioned at start of coordinates upon entry;
C   --upon exit at end of coordinates.

      INTEGER NDB
      CHARACTER*(*) OPTION
      INTEGER NDIM, NUMNP
      REAL XN(*), YN(*), ZN(*)

      CHARACTER*80 ERRMSG

      IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'C') .GT. 0)) THEN
         IF (NDIM .EQ. 1) THEN
            READ (NDB, END=100, ERR=100, IOSTAT=IERR)
     &         (XN(INP), INP=1,NUMNP)
         ELSE IF (NDIM .EQ. 2) THEN
            READ (NDB, END=100, ERR=100, IOSTAT=IERR)
     &         (XN(INP), INP=1,NUMNP), (YN(INP), INP=1,NUMNP)
         ELSE IF (NDIM .EQ. 3) THEN
            READ (NDB, END=100, ERR=100, IOSTAT=IERR)
     &         (XN(INP), INP=1,NUMNP), (YN(INP), INP=1,NUMNP),
     &         (ZN(INP), INP=1,NUMNP)
         ELSE
            READ (NDB, END=100, ERR=100, IOSTAT=IERR)
         END IF
      ELSE
         READ (NDB, END=100, ERR=100, IOSTAT=IERR)
      END IF

      RETURN

  100 CONTINUE
      ERRMSG = 'NODAL COORDINATES'
      CALL DBERR (IERR, ERRMSG)
      RETURN 1
      END

ext: f

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: rfftb1.f,v 1.1 2010/02/23 01:10:43 rtoy Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC)
      REAL       CH(*), C(IN,*), WA(N) ,FAC(15)
C
      NF = FAC(2)
      NA = 0
      DO 10 K1=1,NF
      IP = FAC(K1+2)
      NA = 1-NA
      IF(IP .LE. 5) GO TO 10
      IF(K1 .EQ. NF) GO TO 10
      NA = 1-NA
   10 CONTINUE
      HALF = .5
      HALFM = -.5
      MODN = MOD(N,2)
      NL = N-2
      IF(MODN .NE. 0) NL = N-1
      IF (NA .EQ. 0) GO TO 120
      CH(1) = C(1,1)
      CH(N) = C(1,N)
      DO 118 J=2,NL,2
	 CH(J) = HALF*C(1,J)
	 CH(J+1) = HALFM*C(1,J+1)
  118 CONTINUE
      GO TO 124
  120 DO 122 J=2,NL,2
	 C(1,J) = HALF*C(1,J)
	 C(1,J+1) = HALFM*C(1,J+1)
  122 CONTINUE
  124 L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = FAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
	 CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW))
         GO TO 105
  104    CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
C rav    CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
	 CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
         GO TO 108
  107    CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
         CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),
     1                  WA(IX3),WA(IX4))
         GO TO 111
  110    CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),
     1                  WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
C rav    CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
	 CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
         GO TO 114
C rav 113    CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
  113    CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      RETURN
      END

max_stars_repo_name: wbooze/clocc

max_issues_repo_name: wbooze/clocc

max_forks_repo_name: wbooze/clocc


text:
!****h* ROBODoc/H5G
!
! NAME
!  MODULE H5G
!
! FILE
!  fortran/src/H5Gff.f90
!
! PURPOSE
!  This file contains Fortran interfaces for H5G functions.
!
! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!   Copyright by The HDF Group.                                               *
!   Copyright by the Board of Trustees of the University of Illinois.         *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the files COPYING and Copyright.html.  COPYING can be found at the root   *
!   of the source code distribution tree; Copyright.html can be found at the  *
!   root level of an installed copy of the electronic HDF5 document set and   *
!   is linked from the top-level documents page.  It can also be found at     *
!   http://hdfgroup.org/HDF5/doc/Copyright.html.  If you do not have          *
!   access to either file, you may request a copy from help@hdfgroup.org.     *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
! NOTES
!                         *** IMPORTANT ***
!  If you add a new H5G function you must add the function name to the
!  Windows dll file 'hdf5_fortrandll.def' in the fortran/src directory.
!  This is needed for Windows based operating systems.
!
!*****

MODULE H5G
  USE H5GLOBAL

!  PRIVATE :: h5gcreate1_f
!  PRIVATE :: h5gcreate2_f

!  INTERFACE h5gcreate_f
!  MODULE PROCEDURE h5gcreate1_f
!  MODULE PROCEDURE h5gcreate2_f
!  END INTERFACE

CONTAINS

!****s* H5G/h5gcreate_f
!
! NAME
!  h5gcreate_f
!
! PURPOSE
!  Creates a new group.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - group name at the specified location
! OUTPUTS
!  grp_id 	 - group identifier
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  size_hint 	 - a parameter indicating the number of bytes to
!                  reserve for the names that will appear in the group
!  lcpl_id 	 - Property list for link creation
!  gcpl_id 	 - Property list for group creation
!  gapl_id 	 - Property list for group access
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
!  Added additional optional paramaters in 1.8
!  MSB - February 27, 2008
!
! SOURCE
  SUBROUTINE h5gcreate_f(loc_id, name, grp_id, hdferr, size_hint, lcpl_id, gcpl_id, gapl_id)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of the group
    INTEGER(HID_T), INTENT(OUT) :: grp_id  ! Group identifier
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
    INTEGER(SIZE_T), OPTIONAL, INTENT(IN) :: size_hint
                                           ! Parameter indicating
                                           ! the number of bytes
                                           ! to reserve for the
                                           ! names that will appear
                                           ! in the group. Set to OBJECT_NAMELEN_DEFAULT_F
                                           ! if using any of the optional
                                           ! parameters lcpl_id, gcpl_id, and/or gapl_id when not
                                           ! using keywords in specifying the optional parameters
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: lcpl_id  ! Property list for link creation
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gcpl_id  ! Property list for group creation
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gapl_id  ! Property list for group access
!*****
    INTEGER(HID_T) :: lcpl_id_default
    INTEGER(HID_T) :: gcpl_id_default
    INTEGER(HID_T) :: gapl_id_default

    INTEGER :: namelen ! Length of the name character string
    INTEGER(SIZE_T) :: size_hint_default

    INTERFACE
       INTEGER FUNCTION h5gcreate_c(loc_id, name, namelen, &
            size_hint_default, grp_id, lcpl_id_default, gcpl_id_default, gapl_id_default)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GCREATE_C'::h5gcreate_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         INTEGER(SIZE_T) :: size_hint_default
         INTEGER(HID_T), INTENT(OUT) :: grp_id
         INTEGER(HID_T) :: lcpl_id_default
         INTEGER(HID_T) :: gcpl_id_default
         INTEGER(HID_T) :: gapl_id_default
       END FUNCTION h5gcreate_c
    END INTERFACE

    size_hint_default = OBJECT_NAMELEN_DEFAULT_F
    IF (PRESENT(size_hint)) size_hint_default = size_hint
    lcpl_id_default = H5P_DEFAULT_F
    IF(PRESENT(lcpl_id)) lcpl_id_default = lcpl_id
    gcpl_id_default = H5P_DEFAULT_F
    IF(PRESENT(gcpl_id)) gcpl_id_default = gcpl_id
    gapl_id_default = H5P_DEFAULT_F
    IF(PRESENT(gapl_id)) gapl_id_default = gapl_id

    namelen = LEN(name)

    hdferr = h5gcreate_c(loc_id, name, namelen, size_hint_default, grp_id, &
         lcpl_id_default, gcpl_id_default, gapl_id_default)

  END SUBROUTINE h5gcreate_f

!!$!
!!$!****s* H5G/
!!$!
!!$! NAME
!!$!  h5gcreate2_f
!!$!
!!$! PURPOSE
!!$!	Creates a new group.
!!$!
!!$! INPUTS
!!$!		loc_id		- location identifier
!!$!		name		- group name at the specified location
!!$! OUTPUTS
!!$!		grp_id		- group identifier
!!$!		hdferr:		- error code
!!$!				 	Success:  0
!!$!				 	Failure: -1
!!$! OPTIONAL PARAMETERS
!!$!
!!$!    lcpl_id  - Property list for link creation
!!$!    gcpl_id  - Property list for group creation
!!$!    gapl_id  - Property list for group access
!!$!
!!$! AUTHOR	M. Scot Breitenfeld
!!$!		February 27, 2008
!!$!
!!$! HISTORY
!!$!
!!$! NOTES Needed to switch the first 2 arguments to avoid conflect
!!$!          with h5gcreate1_f
!!$!
!!$
!!$  SUBROUTINE h5gcreate2_f(name, loc_id, grp_id, hdferr, &
!!$        lcpl_id, gcpl_id, gapl_id)
!!$    IMPLICIT NONE
!!$    CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of the group
!!$    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
!!$    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!!$    INTEGER(HID_T), INTENT(OUT) :: grp_id  ! Group identifier
!!$
!!$    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: lcpl_id  ! Property list for link creation
!!$    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gcpl_id  ! Property list for group creation
!!$    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gapl_id  ! Property list for group access
!!$
!!$    INTEGER(HID_T) :: lcpl_id_default
!!$    INTEGER(HID_T) :: gcpl_id_default
!!$    INTEGER(HID_T) :: gapl_id_default
!!$
!!$    INTEGER(SIZE_T) :: OBJECT_NAME
!  LEN_DEFAULT ! Dummy argument to pass to c call
!!$    INTEGER :: namelen ! Length of the name character string
!!$
!!$!  MS FORTRAN needs explicit interface for C functions called here.
!!$!
!!$    INTERFACE
!!$       INTEGER FUNCTION h5gcreate_c(loc_id, name, namelen, &
!!$            OBJECT_NAME
!  LEN_DEFAULT, grp_id, lcpl_id_default, gcpl_id_default, gapl_id_default)
!!$         USE H5GLOBAL
!!$         !DEC$IF DEFINED(HDF5F90_WINDOWS)
!!$         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GCREATE_C'::h5gcreate_c
!!$         !DEC$ENDIF
!!$         !DEC$ATTRIBUTES reference :: name
!!$         INTEGER(HID_T), INTENT(IN) :: loc_id
!!$         CHARACTER(LEN=*), INTENT(IN) :: name
!!$         INTEGER :: namelen
!!$         INTEGER(SIZE_T) :: OBJECT_NAME
!  LEN_DEFAULT
!!$         INTEGER(HID_T) :: lcpl_id_default
!!$         INTEGER(HID_T) :: gcpl_id_default
!!$         INTEGER(HID_T) :: gapl_id_default
!!$         INTEGER(HID_T), INTENT(OUT) :: grp_id
!!$       END FUNCTION h5gcreate_c
!!$    END INTERFACE
!!$
!!$    namelen = LEN(name)
!!$    OBJECT_NAME
!  LEN_DEFAULT = OBJECT_NAME
!  LEN_DEFAULT_F
!!$
!!$    lcpl_id_default = H5P_DEFAULT_F
!!$    IF(PRESENT(lcpl_id)) lcpl_id_default = lcpl_id
!!$    gcpl_id_default = H5P_DEFAULT_F
!!$    IF(PRESENT(gcpl_id)) gcpl_id_default = gcpl_id
!!$    gapl_id_default = H5P_DEFAULT_F
!!$    IF(PRESENT(gapl_id)) gapl_id_default = gapl_id
!!$
!!$
!!$    hdferr = h5gcreate_c(loc_id, name, namelen, OBJECT_NAME
!  LEN_DEFAULT, grp_id, &
!!$         lcpl_id_default, gcpl_id_default, gapl_id_default)
!!$
!!$  END SUBROUTINE h5gcreate2_f

!
!****s* H5G/h5gopen_f
!
! NAME
!  h5gopen_f
!
! PURPOSE
!  Opens an existing group.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the group to open
! OUTPUTS
!  grp_id 	 - group identifier
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  gapl_id 	 - Group access property list identifier
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
!  Added 1.8 (optional) parameter gapl_id
!  February, 2008 M. Scot Breitenfeld
!
! SOURCE
  SUBROUTINE h5gopen_f(loc_id, name, grp_id, hdferr, gapl_id)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of the group
    INTEGER(HID_T), INTENT(OUT) :: grp_id  ! File identifier
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gapl_id  ! Group access property list identifier
!*****
    INTEGER(HID_T) :: gapl_id_default
    INTEGER :: namelen ! Length of the name character string

    INTERFACE
       INTEGER FUNCTION h5gopen_c(loc_id, name, namelen, gapl_id_default, grp_id)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GOPEN_C'::h5gopen_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         INTEGER(HID_T), INTENT(IN) :: gapl_id_default
         INTEGER(HID_T), INTENT(OUT) :: grp_id
       END FUNCTION h5gopen_c
    END INTERFACE

    gapl_id_default = H5P_DEFAULT_F
    IF(PRESENT(gapl_id)) gapl_id_default = gapl_id

    namelen = LEN(name)
    hdferr = h5gopen_c(loc_id, name, namelen, gapl_id_default, grp_id)

  END SUBROUTINE h5gopen_f
!
!****s* H5G/h5gclose_f
!
! NAME
!  h5gclose_f
!
! PURPOSE
!  Closes the specified group.
!
! INPUTS
!  grp_id 	 - group identifier
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gclose_f(grp_id, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: grp_id  ! Group identifier
    INTEGER, INTENT(OUT) :: hdferr        ! Error code
!*****
    INTERFACE
       INTEGER FUNCTION h5gclose_c(grp_id)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GCLOSE_C'::h5gclose_c
         !DEC$ENDIF
         INTEGER(HID_T), INTENT(IN) :: grp_id
       END FUNCTION h5gclose_c
    END INTERFACE

    hdferr = h5gclose_c(grp_id)

  END SUBROUTINE h5gclose_f
!
!****s* H5G/h5gget_obj_info_idx_f
!
! NAME
!  h5gget_obj_info_idx_f
!
! PURPOSE
!  Returns name and type of the group member identified by
!  its index.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the group at the specified location
!  idx 	         - object index (zero-based)
! OUTPUTS
!  obj_name 	 - object name
!  obj_type 	 - object type
!  hdferr 	 - Returns 0 if successful and -1 if fails
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gget_obj_info_idx_f(loc_id, name, idx, &
       obj_name, obj_type, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of the group
    INTEGER, INTENT(IN) :: idx             ! Index of member object
    CHARACTER(LEN=*), INTENT(OUT) :: obj_name   ! Name of the object
    INTEGER, INTENT(OUT) :: obj_type       ! Object type
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTEGER :: namelen ! Length of the name character string
    INTEGER :: obj_namelen ! Length of the obj_name character string

    INTERFACE
       INTEGER FUNCTION h5gget_obj_info_idx_c(loc_id, name, &
            namelen, idx, &
            obj_name, obj_namelen, obj_type)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_OBJ_INFO_IDX_C'::h5gget_obj_info_idx_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         !DEC$ATTRIBUTES reference :: obj_name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         INTEGER, INTENT(IN) :: idx
         CHARACTER(LEN=*), INTENT(OUT) :: obj_name
         INTEGER :: obj_namelen
         INTEGER, INTENT(OUT) :: obj_type
       END FUNCTION h5gget_obj_info_idx_c
    END INTERFACE

    namelen = LEN(name)
    obj_namelen = LEN(obj_name)
    hdferr = h5gget_obj_info_idx_c(loc_id, name, namelen, idx, &
                                           obj_name, obj_namelen, obj_type)
  END SUBROUTINE h5gget_obj_info_idx_f

!
!****s* H5G/h5gn_members_f
!
! NAME
!  h5gn_members_f
!
! PURPOSE
!  Returns the number of group members.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the group at the specified location
! OUTPUTS
!  nmembers 	 - number of group members
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gn_members_f(loc_id, name, nmembers, hdferr)
            IMPLICIT NONE
            INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
            CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of the group
            INTEGER, INTENT(OUT) :: nmembers       ! Number of members in the
                                                   ! group
            INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
            INTEGER :: namelen ! Length of the name character string

            INTERFACE
              INTEGER FUNCTION h5gn_members_c(loc_id, name, namelen, nmembers)
              USE H5GLOBAL
              !DEC$IF DEFINED(HDF5F90_WINDOWS)
              !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GN_MEMBERS_C'::h5gn_members_c
              !DEC$ENDIF
              !DEC$ATTRIBUTES reference :: name
              INTEGER(HID_T), INTENT(IN) :: loc_id
              CHARACTER(LEN=*), INTENT(IN) :: name
              INTEGER :: namelen
              INTEGER, INTENT(OUT) :: nmembers
              END FUNCTION h5gn_members_c
            END INTERFACE

            namelen = LEN(name)
            hdferr = h5gn_members_c(loc_id, name, namelen, nmembers)

          END SUBROUTINE h5gn_members_f
!
!****s* H5G/h5glink_f
!
! NAME
!  h5glink_f
!
! PURPOSE
!  Creates a link of the specified type from new_name
!  to current_name.
!
! INPUTS
!  loc_id 	 - location identifier
!  link_type 	 - link type; possible values are:
!                    H5G_LINK_HARD_F (0)
!                    H5G_LINK_SOFT_F (1)
!  current_name  - name of the existing object if link is a
!                  hard link. Can be anything for the soft link
!  new_name 	 - new name for the object
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5glink_f(loc_id, link_type, current_name, &
       new_name, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    INTEGER, INTENT(IN) :: link_type       ! link type
                                                   ! Possible values are:
                                                   ! H5G_LINK_HARD_F (0) or
                                                   ! H5G_LINK_SOFT_F (1)

    CHARACTER(LEN=*), INTENT(IN) :: current_name
                                                   ! Current name of an object
    CHARACTER(LEN=*), INTENT(IN) :: new_name ! New name of an object
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****

    INTEGER :: current_namelen ! Lenghth of the current_name string
    INTEGER :: new_namelen     ! Lenghth of the new_name string

    INTERFACE
       INTEGER FUNCTION h5glink_c(loc_id, link_type, current_name, &
            current_namelen, new_name, new_namelen)

         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GLINK_C'::h5glink_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: current_name
         !DEC$ATTRIBUTES reference :: new_name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         INTEGER, INTENT(IN) :: link_type
         CHARACTER(LEN=*), INTENT(IN) :: current_name
         INTEGER :: current_namelen
         CHARACTER(LEN=*), INTENT(IN) :: new_name
         INTEGER :: new_namelen
       END FUNCTION h5glink_c
    END INTERFACE

    current_namelen = LEN(current_name)
    new_namelen = LEN(new_name)
    hdferr = h5glink_c(loc_id, link_type, current_name, &
         current_namelen, new_name, new_namelen)
  END SUBROUTINE h5glink_f

!
!****s* H5G/h5glink2_f
!
! NAME
!  h5glink2_f
!
! PURPOSE
!  Creates a link of the specified type from new_name
!  to current_name. current_name and new_name are interpreted
!  releative to current and new location identifiers.
!
! INPUTS
!  cur_loc_id 	 - location identifier
!  cur_name 	 - name of the existing object if link is a
!                  hard link. Can be anything for the soft link.
!  link_type 	 - link type; possible values are:
!                    H5G_LINK_HARD_F (0)
!                    H5G_LINK_SOFT_F (1)
!  new_loc_id 	 - new location identifier
!  new_name 	 - new name for the object
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  September 25, 2002
!
! SOURCE
  SUBROUTINE h5glink2_f(cur_loc_id, cur_name, link_type, new_loc_id, &
       new_name, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: cur_loc_id ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: cur_name
                                             ! Current name of an object
    INTEGER, INTENT(IN) :: link_type         ! link type
                                                 ! Possible values are:
                                                 ! H5G_LINK_HARD_F (0) or
                                                 ! H5G_LINK_SOFT_F (1)

    INTEGER(HID_T), INTENT(IN) :: new_loc_id ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: new_name ! New name of an object
    INTEGER, INTENT(OUT) :: hdferr           ! Error code
!*****

    INTEGER :: cur_namelen ! Lenghth of the current_name string
    INTEGER :: new_namelen ! Lenghth of the new_name string

    INTERFACE
       INTEGER FUNCTION h5glink2_c(cur_loc_id, cur_name, cur_namelen, &
            link_type, new_loc_id, &
            new_name, new_namelen)

         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GLINK2_C'::h5glink2_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: cur_name
         !DEC$ATTRIBUTES reference :: new_name
         INTEGER(HID_T), INTENT(IN) :: cur_loc_id
         INTEGER(HID_T), INTENT(IN) :: new_loc_id
         INTEGER, INTENT(IN) :: link_type
         CHARACTER(LEN=*), INTENT(IN) :: cur_name
         CHARACTER(LEN=*), INTENT(IN) :: new_name
         INTEGER :: cur_namelen
         INTEGER :: new_namelen
       END FUNCTION h5glink2_c
    END INTERFACE

    cur_namelen = LEN(cur_name)
    new_namelen = LEN(new_name)
    hdferr = h5glink2_c(cur_loc_id, cur_name, cur_namelen, link_type, &
         new_loc_id, new_name, new_namelen)
  END SUBROUTINE h5glink2_f

!
!****s* H5G/h5gunlink_f
!
! NAME
!  h5gunlink_f
!
! PURPOSE
!  Removes the specified name from the group graph and
!  decrements the link count for the object to which name
!  points
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the object to unlink
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gunlink_f(loc_id, name, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Name of an object
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTEGER :: namelen ! Lenghth of the name character string

    INTERFACE
       INTEGER FUNCTION h5gunlink_c(loc_id, name, namelen)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GUNLINK_C'::h5gunlink_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
       END FUNCTION h5gunlink_c
    END INTERFACE

    namelen = LEN(name)
    hdferr = h5gunlink_c(loc_id, name, namelen)
  END SUBROUTINE h5gunlink_f

!
!****s* H5G/h5gmove_f
!
! NAME
!  h5gmove_f
!
! PURPOSE
!  Renames an object within an HDF5 file.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - object's name at specified location
!  new_name 	 - object's new name
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gmove_f(loc_id, name, new_name, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id     ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name     ! Current name of an object
    CHARACTER(LEN=*), INTENT(IN) :: new_name ! New name of an object
    INTEGER, INTENT(OUT) :: hdferr           ! Error code
!*****
    INTEGER :: namelen         ! Lenghth of the current_name string
    INTEGER :: new_namelen     ! Lenghth of the new_name string

    INTERFACE
       INTEGER FUNCTION h5gmove_c(loc_id, name, namelen, new_name, new_namelen)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GMOVE_C'::h5gmove_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         !DEC$ATTRIBUTES reference :: new_name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         CHARACTER(LEN=*), INTENT(IN) :: new_name
         INTEGER :: new_namelen
       END FUNCTION h5gmove_c
    END INTERFACE

    namelen = LEN(name)
    new_namelen = LEN(new_name)
    hdferr = h5gmove_c(loc_id, name, namelen, new_name, new_namelen)
  END SUBROUTINE h5gmove_f
!
!****s* H5G/h5gmove2_f
!
! NAME
!  h5gmove2_f
!
! PURPOSE
!  Renames an object within an HDF5 file.
!
! INPUTS
!  src_loc_id 	 - original location identifier
!  src_name 	 - object's name at specified original location
!  dst_loc_id 	 - original location identifier
!  dst_name 	 - object's new name
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
! AUTHOR
!  Elena Pourmal
!  September 25, 2002
!
! SOURCE
  SUBROUTINE h5gmove2_f(src_loc_id, src_name, dst_loc_id, dst_name, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN)   :: src_loc_id  ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: src_name    ! Original name of an object
    INTEGER(HID_T), INTENT(IN)   :: dst_loc_id  ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: dst_name    ! New name of an object
    INTEGER, INTENT(OUT)         :: hdferr      ! Error code
!*****
    INTEGER :: src_namelen         ! Length of the current_name string
    INTEGER :: dst_namelen         ! Lenghth of the new_name string

    INTERFACE
       INTEGER FUNCTION h5gmove2_c(src_loc_id, src_name, src_namelen, &
            dst_loc_id, dst_name, dst_namelen)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GMOVE2_C'::h5gmove2_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: src_name
         !DEC$ATTRIBUTES reference :: dst_name
         INTEGER(HID_T), INTENT(IN) :: src_loc_id
         INTEGER(HID_T), INTENT(IN) :: dst_loc_id
         CHARACTER(LEN=*), INTENT(IN) :: src_name
         CHARACTER(LEN=*), INTENT(IN) :: dst_name
         INTEGER :: src_namelen
         INTEGER :: dst_namelen
       END FUNCTION h5gmove2_c
    END INTERFACE

    src_namelen = LEN(src_name)
    dst_namelen = LEN(dst_name)
    hdferr = h5gmove2_c(src_loc_id, src_name, src_namelen, dst_loc_id, dst_name, dst_namelen)
  END SUBROUTINE h5gmove2_f
!
!****s* H5G/h5gget_linkval_f
!
! NAME
!  h5gget_linkval_f
!
! PURPOSE
!  Returns the name of the object that the symbolic link
!  points to.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - symbolic link to the object whose name
!                  is to be returned.
!  size 	 - maximum number of characters to be returned
! OUTPUTS
!  buffer 	 - a buffer to hold the name of the object
!  being sought
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gget_linkval_f(loc_id, name, size, buffer, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Current name of an object
    INTEGER(SIZE_T), INTENT(IN) :: size    ! Maximum number of buffer
    CHARACTER(LEN=size), INTENT(OUT) :: buffer
                                           ! Buffer to hold a name of
                                           ! the object symbolic link
                                           ! points to
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTEGER :: namelen ! Lenghth of the current_name string

    INTERFACE
       INTEGER FUNCTION h5gget_linkval_c(loc_id, name, namelen, size, buffer)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_LINKVAL_C'::h5gget_linkval_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         !DEC$ATTRIBUTES reference :: buffer
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         INTEGER(SIZE_T), INTENT(IN) :: size
         CHARACTER(LEN=*), INTENT(OUT) :: buffer
       END FUNCTION h5gget_linkval_c
    END INTERFACE

    namelen = LEN(name)
    hdferr = h5gget_linkval_c(loc_id, name, namelen, size, buffer)
  END SUBROUTINE h5gget_linkval_f

!
!****s* H5G/h5gset_comment_f
!
! NAME
!  h5gset_comment_f
!
! PURPOSE
!  Sets comment for specified object.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the object
!  comment 	 - comment to set for the object
! OUTPUTS
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gset_comment_f(loc_id, name, comment, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Current name of an object
    CHARACTER(LEN=*), INTENT(IN) :: comment ! New name of an object
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTEGER :: namelen ! Lenghth of the current_name string
    INTEGER :: commentlen     ! Lenghth of the comment string

    INTERFACE
       INTEGER FUNCTION h5gset_comment_c(loc_id, name, namelen, &
            comment, commentlen)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GSET_COMMENT_C'::h5gset_comment_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name
         !DEC$ATTRIBUTES reference :: comment
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         CHARACTER(LEN=*), INTENT(IN) :: comment
         INTEGER :: commentlen
       END FUNCTION h5gset_comment_c
    END INTERFACE

    namelen = LEN(name)
    commentlen = LEN(comment)
    hdferr = h5gset_comment_c(loc_id, name, namelen, comment, commentlen)
  END SUBROUTINE h5gset_comment_f
!
!****s* H5G/h5gget_comment_f
!
! NAME
!  h5gget_comment_f
!
! PURPOSE
!  Retrieves comment for specified object.
!
! INPUTS
!  loc_id 	 - location identifier
!  name 	 - name of the object at specified location
!  size 	 - size of the buffer required to hold comment
! OUTPUTS
!  buffer 	 - buffer to hold object's comment
!  hdferr 	 - Returns 0 if successful and -1 if fails
!
! AUTHOR
!  Elena Pourmal
!  August 12, 1999
!
! HISTORY
!  Explicit Fortran interfaces were added for
!  called C functions (it is needed for Windows
!  port).  March 5, 2001
!
! SOURCE
  SUBROUTINE h5gget_comment_f(loc_id, name, size, buffer, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: name   ! Current name of an object
    INTEGER(SIZE_T), INTENT(IN) :: size    ! Maximum number of buffer
    CHARACTER(LEN=size), INTENT(OUT) :: buffer
                                           ! Buffer to hold a comment
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTEGER :: namelen ! Lenghth of the current_name string

    INTERFACE
       INTEGER FUNCTION h5gget_comment_c(loc_id, name, namelen, size, buffer)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_COMMENT_C'::h5gget_comment_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: name, buffer
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: name
         INTEGER :: namelen
         INTEGER(SIZE_T), INTENT(IN) :: size
         CHARACTER(LEN=*), INTENT(OUT) :: buffer
       END FUNCTION h5gget_comment_c
    END INTERFACE

    namelen = LEN(name)
    hdferr = h5gget_comment_c(loc_id, name, namelen, size, buffer)

  END SUBROUTINE h5gget_comment_f
!
!****s* H5G/H5Gcreate_anon_f
!
! NAME
!  H5Gcreate_anon_f
!
! PURPOSE
!  Creates a new empty group without linking it into the file structure.
!
! INPUTS
!  loc_id 	 - Location identifier
! OUTPUTS
!  grp_id 	 - group identifier
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  gcpl_id 	 - Group creation property list identifier
!  gapl_id 	 - Group access property list identifier
!
! AUTHOR
!  M. Scot Breitenfeld
!  February 15, 2008
!
! SOURCE
  SUBROUTINE h5Gcreate_anon_f(loc_id, grp_id, hdferr, gcpl_id, gapl_id)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
    INTEGER(HID_T), INTENT(OUT) :: grp_id  ! Group identifier
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gcpl_id  ! Property list for group creation
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: gapl_id  ! Property list for group access
!*****
    INTEGER(HID_T) :: gcpl_id_default
    INTEGER(HID_T) :: gapl_id_default

    INTERFACE
       INTEGER FUNCTION h5gcreate_anon_c(loc_id, gcpl_id_default, gapl_id_default, grp_id)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GCREATE_ANON_C'::h5gcreate_anon_c
         !DEC$ENDIF
         INTEGER(HID_T), INTENT(IN) :: loc_id   ! File or group identifier
         INTEGER(HID_T), INTENT(IN) :: gcpl_id_default  ! Property list for group creation
         INTEGER(HID_T), INTENT(IN) :: gapl_id_default  ! Property list for group access
         INTEGER(HID_T), INTENT(OUT) :: grp_id  ! Group identifier
       END FUNCTION h5gcreate_anon_c
    END INTERFACE

    gcpl_id_default = H5P_DEFAULT_F
    gapl_id_default = H5P_DEFAULT_F

    IF(PRESENT(gcpl_id)) gcpl_id_default = gcpl_id
    IF(PRESENT(gapl_id)) gapl_id_default = gapl_id

    hdferr = h5gcreate_anon_c(loc_id, gcpl_id_default, gapl_id_default, grp_id)

  END SUBROUTINE h5Gcreate_anon_f
!
!****s* H5G/H5Gget_create_plist_f
!
! NAME
!  H5Gget_create_plist_f
!
! PURPOSE
!  Gets a group creation property list identifier.
!
! INPUTS
!  grp_id 	 - group identifier
! OUTPUTS
!  gcpl_id 	 - Group creation property list identifier
!  hdferr 	 - Returns 0 if successful and -1 if fails
! AUTHOR
!  M. Scot Breitenfeld
!  February 15, 2008
!
! SOURCE
  SUBROUTINE h5gget_create_plist_f(grp_id, gcpl_id, hdferr)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN)  :: grp_id  ! Group identifier
    INTEGER(HID_T), INTENT(OUT) :: gcpl_id ! Property list for group creation
    INTEGER, INTENT(OUT) :: hdferr         ! Error code
!*****
    INTERFACE
       INTEGER FUNCTION h5gget_create_plist_c(grp_id, gcpl_id )
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_CREATE_PLIST_C'::h5gget_create_plist_c
         !DEC$ENDIF
         INTEGER(HID_T), INTENT(IN)  :: grp_id
         INTEGER(HID_T), INTENT(OUT) :: gcpl_id
       END FUNCTION h5gget_create_plist_c
    END INTERFACE

    hdferr = h5gget_create_plist_c(grp_id, gcpl_id )

  END SUBROUTINE h5gget_create_plist_f

!
!****s* H5G/h5gget_info_f
!
! NAME
!  h5gget_info_f
!
! PURPOSE
!  Retrieves information about a group
!
! INPUTS
!  group_id 	 - Group identifier
!
! OUTPUTS
!  storage_type  - Type of storage for links in group
!                    H5G_STORAGE_TYPE_COMPACT: Compact storage
!                    H5G_STORAGE_TYPE_DENSE: Indexed storage
!                    H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure
!  nlinks 	 - Number of links in group
!  max_corder 	 - Current maximum creation order value for group
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  mounted 	 - Whether group has a file mounted on it
!
! AUTHOR
!  M. Scot Breitenfeld
!  February 15, 2008
!
! NOTES
!  In C the output is defined as a structure: H5G_info_t
!
! HISTORY
!
!  - Added 'mounted' paramater
!    M. Scot Breitenfeld
!    July 16, 2008
!
! SOURCE
  SUBROUTINE h5gget_info_f(group_id, storage_type, nlinks, max_corder, hdferr, mounted)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: group_id ! Group identifier

    INTEGER, INTENT(OUT) :: storage_type  ! Type of storage for links in group:
                                          ! H5G_STORAGE_TYPE_COMPACT_F: Compact storage
                                          ! H5G_STORAGE_TYPE_DENSE_F: Indexed storage
                                          ! H5G_STORAGE_TYPE_SYMBOL_TABLE_F: Symbol tables, the original HDF5 structure
    INTEGER, INTENT(OUT) :: nlinks        ! Number of links in group
    INTEGER, INTENT(OUT) :: max_corder    ! Current maximum creation order value for group
    INTEGER, INTENT(OUT) :: hdferr        ! Error code:
                                          ! 0 on success and -1 on failure
    LOGICAL, INTENT(OUT), OPTIONAL :: mounted  ! Whether group has a file mounted on it
!*****
    INTEGER :: mounted_c

    INTERFACE
       INTEGER FUNCTION h5gget_info_c(group_id, storage_type, nlinks, max_corder, mounted_c)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_INFO_C'::h5gget_info_c
         !DEC$ENDIF
         INTEGER(HID_T), INTENT(IN) :: group_id
         INTEGER, INTENT(OUT) :: storage_type
         INTEGER, INTENT(OUT) :: nlinks
         INTEGER, INTENT(OUT) :: max_corder
         INTEGER :: mounted_c
       END FUNCTION h5gget_info_c
    END INTERFACE

    hdferr = h5gget_info_c(group_id, storage_type, nlinks, max_corder, mounted_c)

    IF(PRESENT(mounted))THEN
       IF(mounted_c.EQ.0) THEN
          mounted = .FALSE.
       ELSE
          mounted = .TRUE.
       ENDIF
    ENDIF

  END SUBROUTINE h5gget_info_f
!
!****s* H5G/h5gget_info_by_idx_f
!
! NAME
!  h5gget_info_by_idx_f
!
! PURPOSE
!  Retrieves information about a group, according to the group’s position within an index.
!
! INPUTS
!  loc_id 	 - File or group identifier
!  group_name 	 - Name of group containing group for which information is to be retrieved
!  index_type 	 - Index type
!  order 	 - Order of the count in the index
!  n 	         - Position in the index of the group for which information is retrieved
!
! OUTPUTS
!  storage_type  - Type of storage for links in group
!                    H5G_STORAGE_TYPE_COMPACT: Compact storage
!                    H5G_STORAGE_TYPE_DENSE: Indexed storage
!                    H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure
!  nlinks 	 - Number of links in group
!  max_corder 	 - Current maximum creation order value for group
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  lapl_id 	 - Link access property list
!  mounted 	 - Whether group has a file mounted on it
!
! NOTES
!  In C the output is defined as a structure: H5G_info_t
!
! AUTHOR
!  M. Scot Breitenfeld
!  February 18, 2008
!
! HISTORY
!  Added 'mounted' paramater
!  M. Scot Breitenfeld
!  July 16, 2008
!
! SOURCE
  SUBROUTINE h5gget_info_by_idx_f(loc_id, group_name, index_type, order, n, &
       storage_type, nlinks, max_corder, hdferr, lapl_id, mounted)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id       ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: group_name ! Name of group containing group for which information is to be retrieved
    INTEGER, INTENT(IN) :: index_type ! Index type
    INTEGER, INTENT(IN) :: order      ! Order of the count in the index
    INTEGER(HSIZE_T), INTENT(IN) :: n ! Position in the index of the group for which information is retrieved

    INTEGER, INTENT(OUT) :: storage_type ! Type of storage for links in group:
                                         !   H5G_STORAGE_TYPE_COMPACT_F: Compact storage
                                         !   H5G_STORAGE_TYPE_DENSE_F: Indexed storage
                                         !   H5G_STORAGE_TYPE_SYMBOL_TABLE_F: Symbol tables, the original HDF5 structure
    INTEGER, INTENT(OUT) :: nlinks      ! Number of links in group
    INTEGER, INTENT(OUT) :: max_corder  ! Current maximum creation order value for group
    INTEGER, INTENT(OUT) :: hdferr      ! Error code:
                                        ! 0 on success and -1 on failure
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: lapl_id ! Link access property list
    LOGICAL, INTENT(OUT), OPTIONAL :: mounted       ! Whether group has a file mounted on it
!*****
    INTEGER :: mounted_c
    INTEGER(HID_T) :: lapl_id_default
    INTEGER(SIZE_T) :: group_name_len ! length of group name

    INTERFACE
       INTEGER FUNCTION h5gget_info_by_idx_c(loc_id, group_name, group_name_len, index_type, order, n, lapl_id_default, &
            storage_type, nlinks, max_corder, mounted_c)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_INFO_BY_IDX_C'::h5gget_info_by_idx_c
         !DEC$ENDIF

         !DEC$ATTRIBUTES reference :: group_name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: group_name
         INTEGER, INTENT(IN) :: index_type
         INTEGER, INTENT(IN) :: order
         INTEGER(HSIZE_T), INTENT(IN) :: n
         INTEGER(HID_T) :: lapl_id_default
         INTEGER, INTENT(OUT) :: storage_type
         INTEGER, INTENT(OUT) :: nlinks
         INTEGER, INTENT(OUT) :: max_corder

         INTEGER(SIZE_T) :: group_name_len
         INTEGER :: mounted_c

       END FUNCTION h5gget_info_by_idx_c
    END INTERFACE

    group_name_len = LEN(group_name)

    lapl_id_default = H5P_DEFAULT_F
    IF(PRESENT(lapl_id)) lapl_id_default = lapl_id

    hdferr = h5gget_info_by_idx_c(loc_id, group_name, group_name_len, &
         index_type, order, n, lapl_id_default, &
         storage_type, nlinks, max_corder, mounted_c)

    IF(PRESENT(mounted))THEN
       IF(mounted_c.EQ.0) THEN
          mounted = .FALSE.
       ELSE
          mounted = .TRUE.
       ENDIF
    ENDIF

  END SUBROUTINE h5gget_info_by_idx_f
!
!****s* H5G/h5gget_info_by_name_f
!
! NAME
!  h5gget_info_by_name_f
!
! PURPOSE
!  Retrieves information about a group.
!
! INPUTS
!  loc_id 	 - File or group identifier
!  group_name 	 - Name of group containing group for which information is to be retrieved
!
! OUTPUTS
!
!  storage_type  - Type of storage for links in group
!                    H5G_STORAGE_TYPE_COMPACT: Compact storage
!                    H5G_STORAGE_TYPE_DENSE: Indexed storage
!                    H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure
!  nlinks 	 - Number of links in group
!  max_corder 	 - Current maximum creation order value for group
!  hdferr 	 - Returns 0 if successful and -1 if fails
! OPTIONAL PARAMETERS
!  lapl_id 	 - Link access property list
!  mounted 	 - Whether group has a file mounted on it
!
! NOTES
!  In C the output is defined as a structure: H5G_info_t
!
! AUTHOR
!  M. Scot Breitenfeld
!  February 18, 2008
!
! HISTORY
!  Added 'mounted' paramater
!  M. Scot Breitenfeld
!  July 16, 2008
! SOURCE
  SUBROUTINE h5gget_info_by_name_f(loc_id, group_name, &
       storage_type, nlinks, max_corder, hdferr, lapl_id, mounted)
    IMPLICIT NONE
    INTEGER(HID_T), INTENT(IN) :: loc_id       ! File or group identifier
    CHARACTER(LEN=*), INTENT(IN) :: group_name ! Name of group containing group for which information is to be retrieved

    INTEGER, INTENT(OUT) :: storage_type  ! Type of storage for links in group:
                                          ! H5G_STORAGE_TYPE_COMPACT_F: Compact storage
                                          ! H5G_STORAGE_TYPE_DENSE_F: Indexed storage
                                          ! H5G_STORAGE_TYPE_SYMBOL_TABLE_F: Symbol tables, the original HDF5 structure
    INTEGER, INTENT(OUT) :: nlinks        ! Number of links in group
    INTEGER, INTENT(OUT) :: max_corder    ! Current maximum creation order value for group
    INTEGER, INTENT(OUT) :: hdferr        ! Error code:
                                          !   0 on success and -1 on failure
    INTEGER(HID_T), OPTIONAL, INTENT(IN) :: lapl_id ! Link access property list
    LOGICAL, INTENT(OUT), OPTIONAL :: mounted       ! Whether group has a file mounted on it
!*****
    INTEGER :: mounted_c
    INTEGER(HID_T) :: lapl_id_default
    INTEGER(SIZE_T) :: group_name_len ! length of group name

    INTERFACE
       INTEGER FUNCTION h5gget_info_by_name_c(loc_id, group_name, group_name_len, lapl_id_default, &
            storage_type, nlinks, max_corder, mounted_c)
         USE H5GLOBAL
         !DEC$IF DEFINED(HDF5F90_WINDOWS)
         !DEC$ATTRIBUTES C,reference,decorate,alias:'H5GGET_INFO_BY_NAME_C'::h5gget_info_by_name_c
         !DEC$ENDIF
         !DEC$ATTRIBUTES reference :: group_name
         INTEGER(HID_T), INTENT(IN) :: loc_id
         CHARACTER(LEN=*), INTENT(IN) :: group_name
         INTEGER(HID_T), INTENT(IN) :: lapl_id_default
         INTEGER, INTENT(OUT) :: storage_type
         INTEGER, INTENT(OUT) :: nlinks
         INTEGER, INTENT(OUT) :: max_corder

         INTEGER(SIZE_T) :: group_name_len
         INTEGER :: mounted_c

       END FUNCTION h5gget_info_by_name_c
    END INTERFACE

    group_name_len = LEN(group_name)

    lapl_id_default = H5P_DEFAULT_F
    IF(PRESENT(lapl_id)) lapl_id_default = lapl_id

    hdferr = h5gget_info_by_name_c(loc_id, group_name, group_name_len, lapl_id_default, &
         storage_type, nlinks, max_corder, mounted_c)

    IF(PRESENT(mounted))THEN
       IF(mounted_c.EQ.0) THEN
          mounted = .FALSE.
       ELSE
          mounted = .TRUE.
       ENDIF
    ENDIF

  END SUBROUTINE h5gget_info_by_name_f

END MODULE H5G

max_stars_repo_name: pbasting/cactus

max_issues_repo_name: pbasting/cactus

max_forks_repo_name: pbasting/cactus


text: The Center for Mind and Brain was founded by Dr. Ron Mangun as a interdisciplinary effort to understand the human mind. He is the current Director. Members include faculty from Psychology, the Center for Neuroscience, Neurobiology, Physiology, and Behavior (NPB), Linguistics, and Human Development.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search