text:
C To customize this template edit the file
C adapt_system.for
C**********************************************************************
C                           ADAPT                                     *
C                         Version 5                                   *
C**********************************************************************
C                                                                     *
C                       MODEL - AUTO GENERATED                        *
C                                                                     *
C    This file contains Fortran subroutines into which the user       *
C    must enter the relevant model equations and constants.           *
C    Consult the User's Guide for details concerning the format for   *
C    entered equations and definition of symbols.                     *
C                                                                     *
C       1. Symbol-  Parameter symbols and model constants             *
C       2. DiffEq-  System differential equations                     *
C       3. Output-  System output equations                           *
C       4. Varmod-  Error variance model equations                    *
C       5. Covmod-  Covariate model equations (ITS,MLEM)              *
C       6. Popinit- Population parameter initial values (ITS,MLEM)    *
C       7. Prior -  Parameter mean and covariance values (ID,NPD,STS) *
C       8. Sparam-  Secondary parameters                              *
C       9. Amat  -  System state matrix                               *
C                                                                     *
C**********************************************************************

C######################################################################C

        Subroutine SYMBOL
        Implicit None

        Include 'globals.inc'
        Include 'model.inc'

CC
C----------------------------------------------------------------------C
C                   Enter as Indicated                                 C
C----------------------------------------------------------------------C

      NDEqs   =  <SYMBOL_NDEqs>   ! Enter # of Diff. Eqs.
      NSParam =  <SYMBOL_NSParam>   ! Enter # of System Parameters.
      NVParam =  <SYMBOL_NVParam>   ! Enter # of Variance Model Parameters.
      NSecPar =  <SYMBOL_NSecPar>   ! Enter # of Secondary Parameters.
      NSecOut =  0   ! Enter # of Secondary Outputs (not used).
      Ieqsol  =  1   ! Model type: 1 - DIFFEQ, 2 - AMAT, 3 - OUTPUT only.
      Descr = 'Autogenerated Adapt 5 Model Target'

CC
C----------------------------------------------------------------------C
C     Enter Symbol for Each System Parameter (eg. Psym(1)='Kel')       C
C----c-----------------------------------------------------------------C

<SYMBOL_PARAMETER_NAMES>

CC
C----------------------------------------------------------------------C
C    Enter Symbol for Each Variance Parameter {eg: PVsym(1)='Sigma'}   C
C----c-----------------------------------------------------------------C

<SYMBOL_VARIANCE_PARAMETER_NAMES>

CC
C----------------------------------------------------------------------C
C    Enter Symbol for Each Secondary Parameter {eg: PSsym(1)='CLt'}    C
C----c-----------------------------------------------------------------C

<SYMBOL_SECONDARY_PARAMETER_NAMES>

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine DIFFEQ(T,X,XP)
      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Real*8 T,X(MaxNDE),XP(MaxNDE)
<COMMON_BLOCK_DECLARE_PARAMETERS>
<COMMON_BLOCK_DECLARE_STATIC_SECONDARY_PARAMETERS>
<COMMON_BLOCK_DECLARE_STATE_DEFINITIONS>
<COMMON_BLOCK_DECLARE_INFUSION_RATE_DEFINITIONS>
<COMMON_BLOCK_DECLARE_DYNAMIC_SECONDARY_PARAMETERS>

<COMMON_BLOCK_PARAMETERS>
<SECONDARY_PARAMETERS_ASSIGNMENT>
<COMMON_BLOCK_STATE_DEFINITIONS>
<COMMON_BLOCK_INFUSION_RATE_DEFINITIONS>
<COMMON_BLOCK_DYNAMIC_SECONDARY_PARAMETERS>

CC
C----------------------------------------------------------------------C
C     Enter Differential Equations Below  {e.g.  XP(1) = -P(1)*X(1) }  C
C----c-----------------------------------------------------------------C

<ODES_ASSIGNMENT>

<ODES_MAP>

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine OUTPUT(Y,T,X)
      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Real*8 Y(MaxNOE),T,X(MaxNDE)
      Integer DelayPar, I
<COMMON_BLOCK_DECLARE_PARAMETERS>
<COMMON_BLOCK_DECLARE_STATIC_SECONDARY_PARAMETERS>
<COMMON_BLOCK_DECLARE_STATE_DEFINITIONS>
<COMMON_BLOCK_DECLARE_INFUSION_RATE_DEFINITIONS>
<COMMON_BLOCK_DECLARE_DYNAMIC_SECONDARY_PARAMETERS>
<COMMON_BLOCK_DECLARE_OUTPUT_DEFINITIONS>

<COMMON_BLOCK_PARAMETERS>
<SECONDARY_PARAMETERS_ASSIGNMENT>
<COMMON_BLOCK_STATE_DEFINITIONS>
<COMMON_BLOCK_INFUSION_RATE_DEFINITIONS>
<COMMON_BLOCK_DYNAMIC_SECONDARY_PARAMETERS>

CC
C----------------------------------------------------------------------C
C     Enter Output Equations Below   {e.g.  Y(1) = X(1)/P(2) }         C
C----c-----------------------------------------------------------------C

<OUTPUTS_ASSIGNMENT>

<OUTPUTS_MAP>
C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine VARMOD(V,T,X,Y)
      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Real*8 V(MaxNOE),T,X(MaxNDE),Y(MaxNOE)
<COMMON_BLOCK_DECLARE_OUTPUT_DEFINITIONS>
<COMMON_BLOCK_DECLARE_VARIANCE_DEFINITIONS>
<COMMON_BLOCK_DECLARE_VARIANCE_EQUATION_DEFINITIONS>

<COMMON_BLOCK_OUTPUT_DEFINITIONS>
<COMMON_BLOCK_VARIANCE_DEFINITIONS>
<COMMON_BLOCK_VARIANCE_EQUATION_DEFINITIONS>

CC
C----------------------------------------------------------------------C
C       Enter Variance Model Equations Below                           C
C        {e.g. V(1) = (PV(1) + PV(2)*Y(1))**2 }                        C
C----c-----------------------------------------------------------------C

<VARIANCE_ASSIGNMENT>

<VARIANCE_MAP>

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine COVMOD(Pmean, ICmean, PC)
C  Defines any covariate model equations (MLEM, ITS)
      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Real*8 PC(MaxNCP)
      Real*8 Pmean(MaxNSP+MaxNDE), ICmean(MaxNDE)

CC
C----------------------------------------------------------------------C
C     Enter # of Covariate Parameters                                  C
C----c-----------------------------------------------------------------C

      NCparam = 0    ! Enter # of Covariate Parameters.

CC
C----------------------------------------------------------------------C
C   Enter Symbol for Covariate Params {eg: PCsym(1)='CLRenal'}         C
C----c-----------------------------------------------------------------C

CC
C----------------------------------------------------------------------C
C   For the Model Params. that Depend on Covariates Enter the Equation C
C         {e.g. Pmean(1) =  PC(1)*R(2) }                               C
C----c-----------------------------------------------------------------C

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine POPINIT(PmeanI,ICmeanI,PcovI,ICcovI, PCI)
C  Initial parameter values for population program parameters (ITS, MLEM)

      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Integer I,J
      Real*8 PmeanI(MaxNSP+MaxNDE), ICmeanI(MaxNDE)
      Real*8 PcovI(MaxNSP+MaxNDE,MaxNSP+MaxNDE), ICcovI(MaxNDE,MaxNDE)
      Real*8 PCI(MaxNCP)

CC
C----------------------------------------------------------------------C
C  Enter Initial Values for Population Means                           C
C          {  e.g. PmeanI(1) = 10.0    }                               C
C----c-----------------------------------------------------------------C

CC
C----------------------------------------------------------------------C
C   Enter Initial Values for Pop. Covariance Matrix (Lower Triang.)    C
C         {  e.g. PcovI(2,1) = 0.25    }                               C
C----c-----------------------------------------------------------------C

CC
C----------------------------------------------------------------------C
C   Enter Values for Covariate Model Parameters                        C
C         {  e.g. PCI(1) = 2.0    }                                    C
C----c-----------------------------------------------------------------C

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine PRIOR(Pmean,Pcov,ICmean,ICcov)
C  Parameter mean and covariance values for MAP estimation (ID,NPD,STS)
      Implicit None

      Include 'globals.inc'
      Include 'model.inc'

      Integer I,J
      Real*8 Pmean(MaxNSP+MaxNDE), ICmean(MaxNDE)
      Real*8 Pcov(MaxNSP+MaxNDE,MaxNSP+MaxNDE), ICcov(MaxNDE,MaxNDE)

CC
C----------------------------------------------------------------------C
C  Enter Nonzero Elements of Prior Mean Vector                         C
C          {  e.g. Pmean(1) = 10.0    }                                C
C----c-----------------------------------------------------------------C

CC
C----------------------------------------------------------------------C
C   Enter Nonzero Elements of Covariance Matrix (Lower Triang.)       C
C         {  e.g. Pcov(2,1) = 0.25    }                                C
C----c-----------------------------------------------------------------C

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
      Return
      End

C######################################################################C

      Subroutine SPARAM(PS,P,IC)
      Implicit None

      Include 'globals.inc'

      Real*8 PS(MaxNSECP), P(MaxNSP+MaxNDE), IC(MaxNDE)
<COMMON_BLOCK_DECLARE_PARAMETERS>
<COMMON_BLOCK_DECLARE_STATIC_SECONDARY_PARAMETERS>

<COMMON_BLOCK_PARAMETERS>

CC
C----------------------------------------------------------------------C
C       Enter Equations Defining Secondary Paramters                   C
C           {  e.g.  PS(1) = P(1)*P(2)   }                             C
C----c-----------------------------------------------------------------C

<SECONDARY_PARAMETERS_ASSIGNMENT>

<SECONDARY_PARAMETERS_MAP>

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
        Return
        End

C######################################################################C

        Subroutine AMAT(A)
        Implicit None

        Include 'globals.inc'
        Include 'model.inc'

        Integer I,J
        Real*8 A(MaxNDE,MaxNDE)

        DO I=1,Ndeqs
           Do J=1,Ndeqs
              A(I,J)=0.0D0
           End Do
        End Do

CC
C----------------------------------------------------------------------C
C    Enter non zero elements of state matrix  {e.g.  A(1,1) = -P(1) }  C
C----c-----------------------------------------------------------------C

C----------------------------------------------------------------------C
C----------------------------------------------------------------------C
C
        Return
        End

C######################################################################C';

ext: for

max_stars_repo_name: john-harrold/ubiquity-pkpd

max_issues_repo_name: john-harrold/ubiquity-pkpd

max_forks_repo_name: john-harrold/ubiquity-pkpd


text:
The Facilities And Campus Enhancement Initiative was passed by the UC Davis student body in February 1999. The ballot initiative proposed a bundle of loosely related campus upgrades, all under the same bill and carrying a hefty price tag. The unifying theme behind many of the upgrades was the UC Davis UCD athletic departments Move to Division I move from Division II to Division IAA.

 Campus Enhancements

  Multiuse stadium  http://wwwnews.ucdavis.edu/search/news_detail.lasso?id7260 Dateline article
  Schaal Aquatics Center
  ARC Activities and Recreation Center
  Student Recruitment and Retention Center

 Financial impact

All these topnotch facilities (However, the SRRC being in the South Hall basement is far from top notch) are coming at a significant cost to students. To fund the three capital athletic projects, the referendum called for an $18perquarter increase in student fees. The new multiuse stadium under construction will cost $30 million, and studentbased fees from the F.A.C.E. Initiative account for almost twothirds of that cost, according to UCDs Dateline. (I dont know how much of the ARC and Aquatics Center tabs were picked up by students.)

Users/RobertBaron Robert Baron notes that the above statement about the actual cost is not entirely accurate.  Every undergraduate instate student pays $315.00 per year out of their student fees to pay for the F.A.C.E. initiative.  Go to http://budget.ucdavis.edu/studentfees/ to visit the UC Davis Office of Budget & Institutional Analysis for the full breakdown.

 Controversy

Undergraduate Student fees, over the course of (some number of) years, pay for the projects in the FACE initiative. This means that the students who chose to impose these fees on the student body would graduate before paying the bulk of the costs; conversely, UC Davis UCDs current student body, already reeling from a 60 percent overall fee increase since 2001 and facing further tuition hikes, had no say in whether the school would take on this additional financial commitment. Still, most of the students in 1999 realized the heavy consequences of the bill, and a record number of voters turned out to vote on the bill in the winter election.

The initiative passed by seventy percent. In Fall 2004, the ASUCD Senate passed a bill to include an initiative on the next elections ballot to allow students to choose to raise the threshold for new feebased initiatives to a minimum 60 percent majority. If students then passed that ballot measure, it would have served to restrict fee increases from measures with lessthandecisive support from students. FACE was exactly the scenario the bills authors wished to prevent in the future. ThenASUCD ASUCD President President Kalen Gallagher vetoed the bill, and a cowed Senate senate withdrew the bill.

Additionally, the Move to Division I DI transition also requires most of UC Davis UCDs sports teams to sit out the playoff seasons for several years  regardless of how well the teams do before playoffs. UC Davis UCD football will next be eligible for DIAA playoffs in the 20072008 season. http://www.californiaaggie.com/media/storage/paper981/news/2003/09/25/Sports/WhatAre.We.Playing.For1315233.shtml Aggie article

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!! Example of compact vs. contiguous datasets, requires HDF5 >= 1.8
!! for convenience of comparison we create two files,
!! though distinct dataset types can exist in the same file.
!!
!! The file size saving isn't so much, but the advantage is in speed of access
!! particularly when small datasets are frequently read/write

module h5layout

use, intrinsic :: iso_fortran_env, only : REAL64,INT64, stderr=>error_unit
use hdf5
use h5lt, only : h5ltread_dataset_float_f

implicit none (type, external)

private
public :: print_layout, write_layout, sysclock2ms, unlink, bench_write, bench_read

contains

subroutine print_layout(filename, ds_name)
!! prints dataset (variable) layout in a file
character(*), intent(in) :: filename, ds_name

integer :: ierr, layout
integer(hid_t) :: f_id, ds_id, prp_id
INTEGER(HSIZE_T) :: fsize

CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, f_id, ierr)

!> get file size.
CALL h5fget_filesize_f(f_id, fsize, ierr)
print *, filename," size in bytes: ", fsize

!> get dataset storage layout
CALL h5dopen_f(f_id, ds_name, ds_id, ierr)
if (ierr /= 0 ) error stop "problem opening dataset"
CALL h5dget_create_plist_f(ds_id, prp_id, ierr)
CALL h5pget_layout_f(prp_id, layout, ierr)

!> not truly constants, so select case doesn't work
if (layout == H5D_COMPACT_F) then
  print *, ds_name, " layout: COMPACT"
elseif(layout == H5D_CONTIGUOUS_F) then
  print *, ds_name, " layout: CONTIGUOUS"
elseif(layout == H5D_CHUNKED_F) then
  print *, ds_name, " layout: CHUNKED"
else
  error stop "could not determine layout"
end if

call h5pclose_f(prp_id, ierr)
call h5dclose_f(ds_id, ierr)
call h5fclose_f(f_id, ierr)
CALL h5close_f(ierr)

end subroutine print_layout

subroutine write_layout(file_id, ds_name, layout, dat)
!! write real data with HDF5 layout type specified

integer(hid_t), intent(in) :: file_id
character(*), intent(in) :: ds_name
integer, intent(in) :: layout
real, intent(in) :: dat(:)

integer :: ierr
integer(hid_t) :: ds_id, prp_id, space_id
integer(HSIZE_T) :: dims(rank(dat))

dims = shape(dat, HSIZE_T)

!> create dataspace
call h5screate_simple_f(size(dims), dims, space_id, ierr)
if (ierr /= 0) error stop "problem creating dataspace"

!> create dataset property list
call h5pcreate_f(H5P_DATASET_CREATE_F, prp_id, ierr)
if (ierr /= 0) error stop "problem creating property list"

!> config for dataset
call h5pset_layout_f(prp_id, layout, ierr)
if (ierr /= 0) error stop "problem creating layout"

if(layout == H5D_CHUNKED_F) then
   !! normally chunk size set more effectively for actual large datasets.
   call h5pset_chunk_f(prp_id, size(dims), shape(dat, hsize_t), ierr)
   if (ierr /= 0) error stop "problem setting chunk size"
endif

!> create dataset
call h5dcreate_f(file_id, ds_name, H5T_NATIVE_REAL, space_id, ds_id, ierr, dcpl_id=prp_id)
if (ierr /= 0) error stop "problem creating dataset"

!> write data
CALL h5dwrite_f(ds_id, H5T_NATIVE_REAL, dat, dims, ierr)

!> close
call h5pclose_f(prp_id, ierr)
call h5dclose_f(ds_id, ierr)
call h5sclose_f(space_id, ierr)

end subroutine write_layout

impure elemental real(real64) function sysclock2ms(t)
!! Convert a number of clock ticks, as returned by system_clock() called
!! with integer(int64) arguments, to milliseconds

integer(int64), intent(in) :: t
integer(int64) :: rate
call system_clock(count_rate=rate)

sysclock2ms = t * 1000._real64 / rate

end function sysclock2ms

subroutine std_unlink(file)
character(*), intent(in) :: file
integer :: u
open(newunit=u, file=file)
close(u, status="delete")
end subroutine std_unlink

subroutine bench_write(file, layout, dat, N)
character(*), intent(in) :: file
integer, intent(in) :: layout, N
real, intent(in) :: dat(:)

integer(hid_t) :: file_id
integer(int64) :: tic, toc
integer :: ierr, i
character(6) :: name

CALL h5fcreate_f(file, H5F_ACC_TRUNC_F, file_id, ierr)
if (ierr /= 0) error stop "problem creating " // file

call system_clock(count=tic)
do i = 1,N
  write (name, '(A2,I0.4)') '/x',i
  call write_layout(file_id, name, layout, dat)
end do
call system_clock(count=toc)
print *, file,N,"variables: elapsed millisec:",sysclock2ms(toc-tic)

CALL h5fclose_f(file_id, ierr)

end subroutine bench_write

subroutine bench_read(file, N, dat)

character(*), intent(in) :: file
integer, intent(in) :: N
real, intent(out), optional :: dat(:)

integer(hid_t) :: file_id
integer(int64) :: tic, toc
integer(HSIZE_T) :: dims(rank(dat))
integer :: ierr, i
character(6) :: name
real, allocatable :: dbuf(:)

allocate(dbuf(N))
dims = shape(dbuf, HSIZE_T)

CALL h5fopen_f(file, H5F_ACC_RDONLY_F, file_id, ierr)
if (ierr /= 0) error stop "problem opening " // file

call system_clock(count=tic)
do i = 1,N
  write (name, '(A2,I0.4)') '/x',i
  call h5ltread_dataset_float_f(file_id, name, dbuf, dims, ierr)
end do
call system_clock(count=toc)
print *, file,N,"variables: elapsed millisec:",sysclock2ms(toc-tic)

CALL h5fclose_f(file_id, ierr)

end subroutine bench_read

end module h5layout

program compact

use hdf5
use h5layout, only : bench_read, bench_write, std_unlink

implicit none (type, external)

integer :: N, M, ierr

character(:), allocatable :: fn1, fn2, fn3

real, allocatable :: x(:) !< dummy data, could be any TKR

N = 1000
M = 100

fn1 = "bench_compact.h5"
fn2 = "bench_contiguous.h5"
fn3 = "bench_chunked.h5"

!> dummy data
allocate(x(M))

!> Fortran interface
CALL h5open_f(ierr)

!------- compact
call bench_write(fn1, H5D_COMPACT_F, x, N)
call bench_read(fn1, N)

!------- contiguous
call bench_write(fn2, H5D_CONTIGUOUS_F, x, N)
call bench_read(fn2, N)

!-------- chunked
call bench_write(fn3, H5D_CHUNKED_F, x, N)
call bench_read(fn3, N)

!---- cleanup
call h5close_f(ierr)

end program


    program demo_is_iostat_eor
    implicit none
    integer :: stat, i(50)

      open(88, file='test.dat', form='unformatted')
      read(88, iostat=stat) i

      if(is_iostat_eor(stat)) stop 'end of record'

    end program demo_is_iostat_eor


text:
!##########################################################################
        subroutine diffusion
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib
        integer :: is,ie,js,je,ks,ke
        double precision :: dxx,dyy,dzz

! ------ Compute coefficients for diffusion terms

        if(diff_sch.eq.1) then
           fac=dt
        else if(diff_sch.eq.2) then
           fac=dt/2.0
        end if

        do ib=1,nbp
           dom(ib)%ap = 0.0
           dom(ib)%su = 0.0
        end do

        call boundu

        do ib=1,nbp
        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isu; ie=dom(ib)%ieu
        js=dom(ib)%jsu; je=dom(ib)%jeu
        ks=dom(ib)%ksu; ke=dom(ib)%keu

        do k=ks,ke
           do i=is,ie
              do j=js,je

                 dom(ib)%aw(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%ae(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%an(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%as(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%at(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz
                 dom(ib)%ab(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz

                 if (dom(ib)%iprev.lt.0)  dom(ib)%aw(is,j,k)=0.0
                 if (dom(ib)%inext.lt.0)  dom(ib)%ae(ie,j,k)=0.0
                 if (dom(ib)%jprev.lt.0)  dom(ib)%as(i,js,k)=0.0
                 if (dom(ib)%jnext.lt.0)  dom(ib)%an(i,je,k)=0.0
                 if (dom(ib)%kprev.lt.0)  dom(ib)%ab(i,j,ks)=0.0
                 if (dom(ib)%knext.lt.0)  dom(ib)%at(i,j,ke)=0.0

                 dom(ib)%ap(i,j,k) = dom(ib)%ap(i,j,k)-1.0*(
     &  dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &  dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &  dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))+1.0

                 if(diff_sch.eq.1) then
        dom(ib)%su(i,j,k)=dom(ib)%ustar(i,j,k)+dom(ib)%su(i,j,k)
                 else if(diff_sch.eq.2) then
                    dom(ib)%su(i,j,k)=((1.0-
     &dom(ib)%ap(i,j,k))*dom(ib)%u(i,j,k)-
     &dom(ib)%aw(i,j,k)*dom(ib)%u(i-1,j,k)-
     &dom(ib)%ae(i,j,k)*dom(ib)%u(i+1,j,k)-
     &dom(ib)%as(i,j,k)*dom(ib)%u(i,j-1,k)-
     &dom(ib)%an(i,j,k)*dom(ib)%u(i,j+1,k)-
     &dom(ib)%ab(i,j,k)*dom(ib)%u(i,j,k-1)-
     &dom(ib)%at(i,j,k)*dom(ib)%u(i,j,k+1)+
     &dom(ib)%ustar(i,j,k))+dom(ib)%su(i,j,k)
                 end if

                 if (pressureforce) dom(ib)%su(i,j,k)=
     & dom(ib)%su(i,j,k)+forcn*dt

                 if (LENERGY) dom(ib)%su(i,j,k)=
     & dom(ib)%su(i,j,k)+dt*gx*(1.d0-0.5*beta*
     & (dom(ib)%T(i+1,j,k)+dom(ib)%T(i,j,k)) )

                 dom(ib)%ustar(i,j,k)=0.0
              end do
           end do
        end do
        end do

        call sipsol(11)

        do ib=1,nbp
           dom(ib)%ap = 0.0
           dom(ib)%su = 0.0
        end do

        call boundv

        do ib=1,nbp
        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isv; ie=dom(ib)%iev
        js=dom(ib)%jsv; je=dom(ib)%jev
        ks=dom(ib)%ksv; ke=dom(ib)%kev

        do k=ks,ke
           do i=is,ie
              do j=js,je

                 dom(ib)%aw(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%ae(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%an(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%as(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%at(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz
                 dom(ib)%ab(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz

                 if (dom(ib)%iprev.lt.0)  dom(ib)%aw(is,j,k)=0.0
                 if (dom(ib)%inext.lt.0)  dom(ib)%ae(ie,j,k)=0.0
                 if (dom(ib)%jprev.lt.0)  dom(ib)%as(i,js,k)=0.0
                 if (dom(ib)%jnext.lt.0)  dom(ib)%an(i,je,k)=0.0
                 if (dom(ib)%kprev.lt.0)  dom(ib)%ab(i,j,ks)=0.0
                 if (dom(ib)%knext.lt.0)  dom(ib)%at(i,j,ke)=0.0

                 dom(ib)%ap(i,j,k) = dom(ib)%ap(i,j,k)-1.0*(
     &  dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &  dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &  dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))+1.0

                 if(diff_sch.eq.1) then
        dom(ib)%su(i,j,k)=dom(ib)%vstar(i,j,k)+dom(ib)%su(i,j,k)
                 else if(diff_sch.eq.2) then
                    dom(ib)%su(i,j,k)=((1.0-
     &dom(ib)%ap(i,j,k))*dom(ib)%v(i,j,k)-
     &dom(ib)%aw(i,j,k)*dom(ib)%v(i-1,j,k)-
     &dom(ib)%ae(i,j,k)*dom(ib)%v(i+1,j,k)-
     &dom(ib)%as(i,j,k)*dom(ib)%v(i,j-1,k)-
     &dom(ib)%an(i,j,k)*dom(ib)%v(i,j+1,k)-
     &dom(ib)%ab(i,j,k)*dom(ib)%v(i,j,k-1)-
     &dom(ib)%at(i,j,k)*dom(ib)%v(i,j,k+1)+
     &dom(ib)%vstar(i,j,k))+dom(ib)%su(i,j,k)
                 end if

                 if (LENERGY) dom(ib)%su(i,j,k)=
     & dom(ib)%su(i,j,k)+dt*gy*(1.d0-0.5*beta*
     & (dom(ib)%T(i,j+1,k)+dom(ib)%T(i,j,k)) )

                 dom(ib)%vstar(i,j,k)=0.0
              end do
           end do
        end do
        end do

        call sipsol(22)

        do ib=1,nbp
           dom(ib)%ap = 0.0
           dom(ib)%su = 0.0
        end do

        call boundw

        do ib=1,nbp
        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isw; ie=dom(ib)%iew
        js=dom(ib)%jsw; je=dom(ib)%jew
        ks=dom(ib)%ksw; ke=dom(ib)%kew

        do k=ks,ke
           do i=is,ie
              do j=js,je

                 dom(ib)%aw(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%ae(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dxx
                 dom(ib)%an(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%as(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dyy
                 dom(ib)%at(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz
                 dom(ib)%ab(i,j,k)=-fac*dom(ib)%vis(i,j,k)/dzz

                 if (dom(ib)%iprev.lt.0)  dom(ib)%aw(is,j,k)=0.0
                 if (dom(ib)%inext.lt.0)  dom(ib)%ae(ie,j,k)=0.0
                 if (dom(ib)%jprev.lt.0)  dom(ib)%as(i,js,k)=0.0
                 if (dom(ib)%jnext.lt.0)  dom(ib)%an(i,je,k)=0.0
                 if (dom(ib)%kprev.lt.0)  dom(ib)%ab(i,j,ks)=0.0
                 if (dom(ib)%knext.lt.0)  dom(ib)%at(i,j,ke)=0.0

                 dom(ib)%ap(i,j,k) = dom(ib)%ap(i,j,k)-1.0*(
     &  dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &  dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &  dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))+1.0

                 if(diff_sch.eq.1) then
        dom(ib)%su(i,j,k)=dom(ib)%wstar(i,j,k)+dom(ib)%su(i,j,k)
                 else if(diff_sch.eq.2) then
                    dom(ib)%su(i,j,k)=((1.0-
     &dom(ib)%ap(i,j,k))*dom(ib)%w(i,j,k)-
     &dom(ib)%aw(i,j,k)*dom(ib)%w(i-1,j,k)-
     &dom(ib)%ae(i,j,k)*dom(ib)%w(i+1,j,k)-
     &dom(ib)%as(i,j,k)*dom(ib)%w(i,j-1,k)-
     &dom(ib)%an(i,j,k)*dom(ib)%w(i,j+1,k)-
     &dom(ib)%ab(i,j,k)*dom(ib)%w(i,j,k-1)-
     &dom(ib)%at(i,j,k)*dom(ib)%w(i,j,k+1)+
     &dom(ib)%wstar(i,j,k))+dom(ib)%su(i,j,k)
                 end if

                 if (LENERGY) dom(ib)%su(i,j,k)=
     & dom(ib)%su(i,j,k)+dt*gz*(1.d0-0.5*beta*
     & (dom(ib)%T(i,j,k+1)+dom(ib)%T(i,j,k)) )

                 dom(ib)%wstar(i,j,k)=0.0
              end do
           end do
        end do
        end do

        call sipsol(33)

        if (LROUGH) call rough_velocity

        return
        end subroutine diffusion
!##########################################################################


text:
      program hpftest24
      integer j(10), i, k, d
chpf$ template t(20)
chpf$ align j(i) with t(2*i-1)
chpf$ processors p(3)
chpf$ distribute t(block) onto p
      print *, 'hpftest24 running'
chpf$ INDEPENDENT(i)
      do i=1, 10
         j(i) = i
      enddo
chpf$ independent(i)
      do i=1,5
         k = 11-i
         d = j(i)
         j(i) = j(k)
         j(k) = d
      enddo
      do i=1,10
         print *, 'j(',i,') = ',j(i)
      enddo
      print *, 'hpftest24 ended'
      end


program main

  use excel_mo

  implicit none

  integer, parameter :: NFMS = 9 ! Number of formats

  type(c_ptr)            :: wb(1)      ! Workbook pointer
  type(c_ptr)            :: ws(1:3)    ! Worksheet pointer
  type(c_ptr)            :: fm(0:NFMS) ! Format pointer ! 0 is reserved for no format
  type(image_options_ty) :: op
  type(datetime_ty)      :: dt

  integer i

#define CELL(cell) name2row(cs(cell)), name2col(cs(cell))
#define COLS(cols) name2col(cs(cols)), name2col2(cs(cols))
#define RANGE(range) name2row(cs(range)), name2col(cs(range)), name2row2(cs(range)), name2col2(cs(range))

  ! Macro
  print *, 'CELL:', CELL('A2')
  print *, 'COLS:', COLS('A:C')
  print *, 'RANGE:', RANGE('A1:C3')

  ! Workbook and worksheets
  wb(1) = workbook_new ( file = cs('test.xlsx') )
  ws(1) = workbook_add_worksheet ( wb(1), cs('first_sheet') )
  ws(2) = workbook_add_worksheet ( wb(1), cs('second_sheet') )
  ws(3) = workbook_add_worksheet ( wb(1), cs('third_sheet') )
 ! call worksheet_activate ( ws(2) )
 ! call worksheet_hide     ( ws(3) )
  call worksheet_set_tab_color ( ws(1), cs('lime') )

  ! Header and footer
  call worksheet_set_header ( ws(1), cs('header') )
  call worksheet_set_footer ( ws(1), cs('footer') )

  ! Format settings
  do i = 0, NFMS

    fm(i) = workbook_add_format ( wb(1) ) ! test

    if ( mod ( i, 2 ) == 0 .and. i > 0 .and. i < 5 ) then
      call format_set_bg_color ( fm(i), cs('cyan') )
    end if

  end do

  ! Header of table
  call worksheet_set_row     ( ws(1), fm(0), row = 1, height = 40 )
  call worksheet_set_column  ( ws(1), fm(0), col = 2, width  = 40 )
  call format_set_bold       ( fm(1) )
  call format_set_bg_color   ( fm(1), cs('navy')  )
  call format_set_font_color ( fm(1), cs('white') )
  call format_set_font_name  ( fm(1), cs('YuKyokasho') )
  call format_set_align      ( fm(1), cs('center') )
  call format_set_align      ( fm(1), cs('vertical_center') )
  call format_set_font_size  ( fm(1), 20 )
  call worksheet_write_string ( ws(1), fm(1), row = 1, col = 1, string = cs('Ho-gens')     )
  call worksheet_write_string ( ws(1), fm(1), row = 1, col = 2, string = cs('Panic Level') )

  ! Table
  call worksheet_write_string ( ws(1), fm(2), row = 2, col = 1, string = cs('Yoka')        )
  call worksheet_write_string ( ws(1), fm(3), row = 3, col = 1, string = cs('Batten')      )
  call worksheet_write_string ( ws(1), fm(4), row = 4, col = 1, string = cs('Batten-gara') )
  call worksheet_write_number ( ws(1), fm(2), row = 2, col = 2, value = 1.02d0 )
  call worksheet_write_number ( ws(1), fm(3), row = 3, col = 2, value = 3.14d0 )
  call worksheet_write_number ( ws(1), fm(4), row = 4, col = 2, value = 99.0d0 )
  call worksheet_autofilter  ( ws(1), 1, 1, 4, 2 )

  ! Black line
  call worksheet_set_row ( ws(1), fm(0), row = 5, height = 5 )

  ! Totals
  call format_set_align      ( fm(8), cs('right') )
  call format_set_align      ( fm(8), cs('vertical_right') )
  call format_set_bold       ( fm(8) )
  call worksheet_write_string  ( ws(1), fm(8), row = 6, col = 1, string = cs('Totals:') )
  call worksheet_write_comment ( ws(1), row = 6, col = 1, string = cs('This is comment') )

  call format_set_num_format ( fm(9), cs('0.0') )
  call format_set_bg_color   ( fm(9), cs('yellow')  )
  call format_set_border     ( fm(9), cs('thick')  )
  call worksheet_write_formula ( ws(1), row = 6, col = 2, formula = cs('=SUM(B2:B4)'), format = fm(9) )

  ! Insert image
  op = image_set_options ( x_offset = 10, y_offset = 10, x_scale = 0.5d0, y_scale = 0.5d0, position = cs('move_and_size') )
  call worksheet_insert_image_opt ( ws(1), row = 15, col = 1, file = cs('fig.png'), options = op )
  call worksheet_insert_image     ( ws(1), row =  8, col = 1, file = cs('fig.png') )

  ! Datetime
  dt = datetime_ty( year = 2021, month = 3, day = 1, hour = 2, min = 30, sec = 10.d0 )
  call format_set_num_format ( fm(7), cs('yyyy-mm-dd hh:mm:ss') )
  call worksheet_write_datetime( ws(1), CELL('B7'), dt, fm(7) )

  ! URL
  call format_set_font_color ( fm(5), cs('blue') )
  call format_set_underline ( fm(5), cs('single') )
  call worksheet_write_url ( ws(1), row = 8, col = 2, url = cs('http://libxlsxwriter.github.io'), format = fm(5) )

  ! Defined name
  call workbook_define_name ( wb(1), name = cs('Exchange_rate'), formula = cs('=110.0') )
  call worksheet_write_formula ( ws(1), row = 9, col = 2, formula = cs('=Exchange_rate'), format = fm(0) )

  ! Merge range
  call worksheet_merge_range ( ws(1), RANGE('C1:E1'), cs('Merged range'), fm(1) )

  ! Close the workbook
  call workbook_close ( wb(1) )

end program


text:
      module LOADBALANCER_DEBUG
!----
!     Usage:
!       Both production and debug mode:
!         call ASSERT(x)
!----

      interface ASSERT
        module procedure ASSERT_1
        module procedure ASSERT_2
      end interface

      contains

      subroutine ASSERT_1(x)
        logical :: x
        if( .not.x )then
          error stop "Assertion Error"
        end if
      end subroutine ASSERT_1

      subroutine ASSERT_2(x, message)
        logical :: x
        character ( len = * ) :: message
        if( .not.x )then
          error stop "Assertion Error: "//message
        end if
      end subroutine ASSERT_2

      end module LOADBALANCER_DEBUG

max_stars_repo_name: NLESC-JCER/QUICKLB

max_issues_repo_name: NLESC-JCER/QUICKLB

max_forks_repo_name: NLESC-JCER/QUICKLB


text:
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c.... Print a summary of all the good observations.

      subroutine OBSSMRY ( lu, nobs, kx, ktype )
      use m_ioutil,only : luflush

c.......................................................................
c.... Argument declarations.

      integer      lu
      integer      nobs
      integer      kx(nobs)
      integer      ktype(nobs)

c.......................................................................
c.... Data source names.

      include     "ktmax.h"
      include     "kxmax.h"
      include     "kxtabl.h"

c.......................................................................
c.... Data type names.

      include     "kttabl.h"

c.......................................................................
c.... Local storage for counters.

      integer      ksums(kxmax,ktmax)
      integer      ktots(ktmax)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c.......................................................................
c.... Initialize counters.

      do 110 j = 1, ktmax
         ktots(j) = 0
         do 100 i = 1, kxmax
            ksums(i,j) = 0
  100    continue
  110 continue

c.......................................................................
c.... Count up the data by source and type.

      do 200 n = 1, nobs
         ksums(kx(n),ktype(n)) = ksums(kx(n),ktype(n)) + 1
         ktots(ktype(n))       = ktots(ktype(n))       + 1
  200 continue

c.......................................................................
c.... Write the observation summary sub-tables for each data source.

      do 300 i = 1, kxmax

         ksum = 0
         do 250 j = 1, ktmax
            ksum = ksum + ksums(i,j)
  250    continue

         if( ksum.gt.0 ) then

            write(lu,900) i, kxdesc(i)
  900       format('  obssmry:  kx    = ',I3,'  kxdesc = ',A25)

            do 275 j = 1, ktmax

               if( ksums(i,j).ne.0 ) then
                  write(lu,910) j, ktname(j), ksums(i,j)
  910             format('  obssmry:  ktype = ',I3,'  ktname = ',A9,I10)
               endif

  275       continue
            write(lu,920)
  920       format('  obssmry:')

         endif

  300 continue

c.......................................................................
c.... Write the observation summary table for all data sources.

      kgrand = 0
      write(lu,900) 9999, 'ALL KXs '

      do 325 j = 1, ktmax

         kgrand = kgrand + ktots(j)
         write(lu,910) j, ktname(j), ktots(j)

  325 continue

      write(lu,920)
      write(lu,910) 9999, 'ALL KTs ', kgrand
      write(lu,920)
      call luflush(lu)

      return

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      end

max_stars_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
!!
!! REGRESION IN 14.0.1 AGAINST 14.0.0 AND 13.x
!!
!! The following stripped-down reproducer compiles without error using 14.0.0
!! and the 13.x compiler versions, but the 14.0.1 compiler issues an error:
!!
!! $ ifort --version
!! ifort (IFORT) 14.0.1 20131008
!! $ ifort -c intel-bug-20140109.f90
!! intel-bug-20140109.f90(80): error #6401: The attributes of this name conflict with those made accessible by a USE statement.   [SIZE]
!!     n = size(T2obj) ! THE COMPILER COMPLAINS ABOUT THE ATTRIBUTES OF THE 'SIZE' NAME
!! --------^
!!
!! The error is incorrect.  T1mod defines a generic interface SIZE for TYPE(T1)
!! arguments, and T2mod, which uses T1mod, extends that interface for TYPE(T2)
!! arguments.  There is no conflict as claimed.  T1mod also defines a couple of
!! completely extraneous generic interfaces, however if any one of these are
!! removed from the example it compiles without error.  Further, if either of
!! the public statements is removed (they are redundant -- all entities are
!! public) the example compiles without error.
!!

module T1mod

  type T1
    integer, pointer :: array(:)
  end type

  interface size
    module procedure T1size
  end interface

  interface generic1
    module procedure sub1
  end interface

  interface generic2
    module procedure sub2
  end interface

contains

  integer function T1size (AtlasData)
    type(T1), intent(IN) :: AtlasData
    T1size = 0
  end function

  subroutine sub1 (T1obj, size)
    type(t1) :: t1obj
    integer :: size
  end subroutine

  subroutine sub2 (T1obj, rank)
    type(T1) :: T1obj
    integer :: rank(size(T1obj%array))
  end subroutine

end module

module T2mod

  use T1mod

  public :: generic1
  public :: generic2

  type T2
    integer :: n
  end type

  interface size
     module procedure T2size
  end interface

contains

  integer function T2size (T2obj)
    type(T2) :: T2obj
    T2size = T2obj%n
  end function

  subroutine sub3 (T2obj)
    type(T2) :: T2obj
    n = size(T2obj) ! THE COMPILER COMPLAINS ABOUT THE ATTRIBUTES OF THE 'SIZE' NAME
  end subroutine

end module

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


text:
      SUBROUTINE CMHGEN
C
C     THIS SUBROUTINE GENERATES THE (H) TRANSFORMATION MATRICES FOR
C     COMPONENT SUBSTRUCTURES IN A COMBINE OPERATION AND WRITES THEM
C     ON THE SOF
C
      LOGICAL         FRSFIL
      INTEGER         BUFEX,SCR1,MCB(7),IHEAD(2),NAM(2),SCR3,BUF1,
     1                CNAM,COMBO,Z,SSIL,LCORE,SCORE,SCSFIL,BUF2,BUF3,
     2                SCBDAT,SCCONN,LISTO(32),LISTN(32),AAA(2),BUF4,
     3                CE(10)
      DIMENSION       T(6,6),TP(6,6),TPP(6,6),COLOUT(6),TID(6,6),
     1                TTRAN(6,6)
      COMMON /CMB001/ SCR1,SCR2,SCBDAT,SCSFIL,SCCONN,SCMCON,SCTOC,
     1                GEOM4,CASECC,SCCSTM,SCR3
      COMMON /CMB002/ BUF1,BUF2,BUF3,BUF4,BUF5,SCORE,LCORE,INPT,OUTT
      COMMON /CMB003/ COMBO(7,5),CONSET,IAUTO,TOLER,NPSUB
      COMMON /CMB004/ TDAT(6),NIPNEW,CNAM(2)
      COMMON /ZZZZZZ/ Z(1)
      COMMON /PACKX / IIN,IOUT,IIII,NNNN,INCR
      DATA    ZERO  / 0.0 /,AAA/ 4HCMHG,4HEN   /,IHEAD/ 4HHORG,4H    /
      DATA    TID   / 1.,0.,0.,0.,0.,0., 0.,1.,0.,0.,0.,0.,
     1                0.,0.,1.,0.,0.,0., 0.,0.,0.,1.,0.,0.,
     2                0.,0.,0.,0.,1.,0., 0.,0.,0.,0.,0.,1. /
      DATA    NHEQSS/ 4HEQSS   /
C
C     READ SIL,C FROM SOF FOR COMBINED STRUCTURE
C
      INCR  = 1
      BUFEX = LCORE - BUF2 + BUF3
      LCORE = BUFEX - 1
      IF (LCORE .LT. 0) GO TO 320
      IOEFIL = 310
      CALL OPEN (*300,IOEFIL,Z(BUFEX),0)
      MCB(1) = SCR1
      MCB(4) = 2
      MCB(5) = 1
      IIN    = 1
      IOUT   = 1
      CALL SFETCH (CNAM,NHEQSS,1,ITEST)
      NSUB = 0
      DO 10 I = 1,NPSUB
      NSUB = NSUB + COMBO(I,5)
   10 CONTINUE
      CALL SJUMP (NSUB+1)
      CALL SUREAD (Z(SCORE),-1,NSILNW,ITEST)
C
C     LOOP ON NUMBER OF PSEUDO-STRUCTURES BEING COMBINED
C
      SSIL  = SCORE + NSILNW
      LCORE = LCORE - NSILNW
      IFILE = SCR3
      CALL OPEN (*300,SCR3,Z(BUF1),0)
      IFILE = SCSFIL
      CALL OPEN (*300,SCSFIL,Z(BUF2),0)
C
      DO 260 I = 1,NPSUB
      FRSFIL = .TRUE.
      MCB(2) = 0
      MCB(6) = 0
      MCB(7) = 0
C
C     READ SIL,C FOR COMPONENT SUBSTRUCTURE
C
      NCS = COMBO(I,5) + 2
      DO 20 J = 1,NCS
      CALL FWDREC (*310,SCSFIL)
   20 CONTINUE
      IFILE = IOEFIL
      CALL READ (*310,*30,IOEFIL,Z(SSIL),LCORE,1,NSLOLD)
      GO TO 320
   30 ISHPTR = SSIL + NSLOLD
      IFILE  = SCSFIL
      CALL READ (*310,*40,SCSFIL,Z(ISHPTR),LCORE,1,LHPTR)
      GO TO 320
   40 CALL SKPFIL (SCSFIL,1)
C
C     COMPUTE NUMBER OF ROWS IN MATRIX
C
      ICODE = Z(SSIL+NSLOLD-1)
      CALL DECODE (ICODE, LISTO, NCOM)
      MCB(3) = Z(SSIL+NSLOLD-2) + NCOM - 1
C
C     READ CONNECTION ENTRIES
C
C     READ TRANSFORMATION MATRIX FOR PSEUDOSTRUCTURE
C
      IFILE = SCR3
      CALL READ (*310,*50,SCR3,TTRAN,37,1,NNN)
   50 CONTINUE
      CALL SKPFIL (SCR3,-1)
      IF (I .NE. 1) CALL SKPFIL (SCR3,1)
      IFILE = SCCONN
      CALL OPEN (*300,SCCONN,Z(BUF3),0)
      IFILE = SCR1
      CALL OPEN (*300,SCR1,Z(BUF4),1)
      CALL WRITE (SCR1,IHEAD,2,1)
      IPNEW = 0
   60 CALL READ (*250,*70,SCCONN,CE,10,1,NNN)
   70 IPNEW  = IPNEW + 1
      LOCIPN = SCORE + 2*(IPNEW-1) + 1
      IF (CE(I+2) .EQ. 0) GO TO 230
      IPOLD  = CE(I+2)
      LOCIPO = SSIL + 2*(IPOLD-1) + 1
      ICODE  = Z(LOCIPN)
      CALL DECODE (ICODE,LISTN,NCN)
      ICODE  = Z(LOCIPO)
      CALL DECODE (ICODE,LISTO,NCO)
C
      IADDH = ISHPTR + IPOLD - 1
      IDH   = Z(IADDH)
      IF (IDH-1) 80,100,120
C
C     IDENTITY MATRIX
C
   80 CONTINUE
      DO 90 I1 = 1,6
      DO 90 I2 = 1,6
      T(I1,I2) = TID(I1,I2)
   90 CONTINUE
      GO TO 160
C
C     TRANS MATRIX
C
  100 CONTINUE
      DO 110 I1 = 1,6
      DO 110 I2 = 1,6
      T(I1,I2) = TTRAN(I1,I2)
  110 CONTINUE
      GO TO 160
C
C     MATRIX DUE TO GTRAN
C
  120 CONTINUE
      IDHM1 = IDH - 1
      DO 130 I1 = 1,IDHM1
      CALL FWDREC (*310,SCR3)
  130 CONTINUE
      CALL READ (*310,*140,SCR3,T,37,1,NNN)
  140 DO 150 I1 = 1,IDH
      CALL BCKREC (SCR3)
  150 CONTINUE
  160 CONTINUE
C
C     DELETE ROWS OF (T) FOR EACH COLD EQUAL TO ZERO
C
      DO 180 J1 = 1,NCO
      IR = LISTO(J1) + 1
      DO 170 J2 = 1,6
      TP(J1,J2) = T(IR,J2)
  170 CONTINUE
  180 CONTINUE
      NROW = NCO
C
C     DELETE COLUMNS OF (T) FOR EACH CNEW EQUAL TO ZERO
C
      DO 200 J1 = 1,NCN
      IC = LISTN(J1) + 1
      DO 190 J2 = 1,NROW
      TPP(J2,J1) = TP(J2,IC)
  190 CONTINUE
  200 CONTINUE
      NCOL = NCN
      DO 220 I1 = 1,NCOL
      DO 210 I2 = 1,NROW
      COLOUT(I2) = TPP(I2,I1)
  210 CONTINUE
      IIII = Z(LOCIPO-1)
      NNNN = IIII + NROW - 1
      CALL PACK (COLOUT,SCR1,MCB)
  220 CONTINUE
      GO TO 60
  230 IIII = 1
      NNNN = 1
      ICODE = Z(LOCIPN)
      CALL DECODE (ICODE,LISTN,NCN)
      DO 240 I1 = 1,NCN
      CALL PACK (ZERO,SCR1,MCB)
  240 CONTINUE
      GO TO 60
  250 CONTINUE
      CALL CLOSE (SCCONN,1)
      CALL WRTTRL (MCB)
      CALL CLOSE (SCR1,1)
      NAM(1) = COMBO(I,1)
      NAM(2) = COMBO(I,2)
      CALL MTRXO (SCR1,NAM,IHEAD(1),Z(BUF4),ITEST)
      CALL SKPFIL (SCR3,1)
  260 CONTINUE
C
      CALL CLOSE (SCSFIL,1)
      CALL CLOSE (SCR3,1)
      CALL CLOSE (IOEFIL,1)
      LCORE = BUFEX + BUF2 - BUF3
      RETURN
C
  300 IMSG = -1
      GO TO 330
  310 IMSG = -2
      GO TO 330
  320 IMSG = -8
  330 CALL MESAGE (IMSG,IFILE,AAA)
      RETURN
      END


text:
The Blanchard Community Room is located at the Yolo County Library  Davis Branch and can meeting rooms host an event for 120 seated persons. See the http://www.yolocounty.org/Index.aspx?page1303 library website for information on using the room. The room is named in honor of J. Richard Blanchard, who was librarian at UC Davis and the first librarian at its School of Veterinary Medicine.

The Blanchard Community Room has a maximum occupancy of 176 persons, with 120 approximate seating capacity, and 100 approximately parking spaces.

The Blanchard Community Room is equipped with:  8 sixfoot tables, a pulldown screen, an overhead projector, a slide projector with an 80slide tray, a 32” TV and DVD/VCR on a cart, a podium, sound system, a 16mm projector with reel, a small cart with electrical cord, a piano, and an easel.

Kitchen facilities, including a refrigerator, microwave, and electric range, are available.  Groups utilizing kitchen facilities must provide their own supplies.  There is a $10.00 fee to use the kitchen or serve food and beverages.

The fee for use of the Blanchard Community Room is $10.00 per hour (or any portion of an hour) when the library is closed.  This charge is in addition to the $10.00 food and beverage fee.  A call back fee is charged ($50.00) if the security system is not set properly when the room is used after the Library is closed.

On Wednesdays, the Blanchard Room hosts an After School Club for youth in 4th, 5th, and 6th grades from 1:30 to 3:15.  Activities and snacks are provided.

 Events that Recur Here
  LUGOD meets here regularly, every third Monday of the month (except when the room is sometimes unavailable).


text:
!====================================================================
    MODULE hf_inout
!====================================================================
!
!   contains input/output parameters
!
!--------------------------------------------------------------------

       IMPLICIT NONE
       SAVE

       INTEGER(4) :: err = 0 !   error (system default for screen)
       INTEGER(4) :: log = 3 !   hf_log file
       INTEGER(4) :: scr = 6 !   screen output
       INTEGER(4) :: iuc = 20 !   input unit for bsw.c (if present)
       INTEGER(4) :: iuf = 21 !   input unit for bsw.inp (if present)
       INTEGER(4) :: iup = 22 !   input unit for hf_param (if present)
       INTEGER(4) :: ouf = 31 !   output unit for bsw.out
       INTEGER(4) :: plt = 41 !   plot.dat file (for plotting)
       INTEGER(4) :: ryd = 42 !   file for Rydberg series orbitals

    CONTAINS
!====================================================================
       SUBROUTINE open_files
!====================================================================
!   Open files to be used
!--------------------------------------------------------------------
          IMPLICIT NONE
          Logical :: old

          OPEN (UNIT=log, FILE='sphf.log', STATUS='UNKNOWN', POSITION='asis')
          INQUIRE (FILE='bsw.c', EXIST=OLD)
          IF (OLD) &
             OPEN (UNIT=IUC, FILE='bsw.c', STATUS='OLD', FORM='FORMATTED')
          INQUIRE (FILE='bsw.inp', EXIST=OLD)
          IF (OLD) &
             OPEN (UNIT=IUF, FILE='bsw.inp', STATUS='OLD', FORM='UNFORMATTED')
          INQUIRE (FILE='hf_param', EXIST=OLD)
          IF (OLD) OPEN (UNIT=iup, FILE='hf_param', STATUS='OLD', &
                         FORM='FORMATTED')
          OPEN (UNIT=OUF, FILE='bsw.out', STATUS='UNKNOWN', FORM='UNFORMATTED')
          OPEN (UNIT=plt, FILE='plot.dat', STATUS='UNKNOWN')
       END subroutine open_files

!====================================================================
    END MODULE hf_inout

max_stars_repo_name: compas/sphf

max_issues_repo_name: compas/sphf

max_forks_repo_name: compas/sphf


text:
module dStar_atm_def
    use constants_def

    integer, parameter :: atm_default_number_table_points = 256
    real(dp), parameter :: atm_default_lgTbmin = 7.0
    real(dp), parameter :: atm_default_lgTbmax = 9.5
    real(dp), parameter :: default_lgTeff_min = 5.5
    real(dp), parameter :: default_lgTeff_max = 7.0

    type atm_table_type
        logical :: is_loaded
        integer :: nv
        real(dp) :: lgTb_min, lgTb_max
        real(dp), dimension(:), allocatable :: lgTb
        ! storage of interpolation coefficients
        real(dp), dimension(:), pointer :: lgTeff=>null()
        real(dp), dimension(:), pointer :: lgflux=>null()
    end type atm_table_type

    type(atm_table_type), target :: atm_table
    logical :: atm_is_initialized = .FALSE.
    character(len=256) :: atm_datadir

end module dStar_atm_def

max_stars_repo_name: LBJ-Wade/dStar

max_issues_repo_name: LBJ-Wade/dStar

max_forks_repo_name: LBJ-Wade/dStar


text:
      DOUBLE PRECISION FUNCTION ZTHZ(H,IH,Z,IZ,N,I1,I2)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                     UNIVERSIDAD DE CANTABRIA                         *
C                     ------------------------                         *
C                          FEBRERO 1988                                *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Este subprograma calcula el elemento  (i1,i2)  del producto
C        matricial  ZTHZ.
C
C     LISTA DE LLAMADA:
C
C        H     Matriz  de  dimension  (IH,N)  que  contiene, en  sus  N
C              primeras filas, la matriz  H.  Es suficiente  suministrar
C              la parte triangular inferior. El resto de la matriz no se
C              utiliza.
C
C        IH    Primera dimension de la matriz  H. IH >= N.
C
C        Z     Matriz de dimension  (IZ,*) que contiene la matriz  Z.
C
C        IZ    Primera dimension de la matriz  Z. IZ >= N.
C
C        N     Numero de filas de  Z, numero de filas y columnas de  H.
C
C      I1,I2   (I1,I2) indica el elemento que se desea calcular.
C
C        Este subprograma trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: ddot
C     FUNCIONES FORTRAN INTRINSECAS: mod
C
C
      implicit double precision(a-h,o-z)
      dimension h(ih,*),z(iz,*)
      zthz=0
      do 10 j=1,n
         jj=j+1
         s=ddot(j,h(j,1),ih,z(1,i2),1)
         s=s+ddot(n-j,h(jj,j),1,z(jj,i2),1)
         zthz=zthz+s*z(j,i1)
10    continue
      end

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


text:
	FUNCTION PR_COML  ( chc1, chc2, chc3 )
C************************************************************************
C* PR_COML								*
C*									*
C* This function gets COML from CHC1, CHC2, and CHC3.  COML is the	*
C* combined height and numeric sky coverage for low clouds which	*
C* are those whose height is less than 63,000 feet.			*
C*									*
C* REAL PR_COML  ( CHC1, CHC2, CHC3 )					*
C*									*
C* Input parameters:							*
C*	CHC1		REAL		Cloud height & coverage 1	*
C*	CHC2		REAL		Cloud height & coverage 2	*
C*	CHC3		REAL		Cloud height & coverage 3	*
C*									*
C* Output parameters:							*
C*	PR_COML		REAL		Low combined height & coverage	*
C**									*
C* Log:									*
C* S. Schotz/GSC	10/89						*
C* M. desJardins/GSFC	 7/90	Documentation; -X always to low clouds	*
C* K. Brill/NMC		11/91	Choose low cld rprt of greatest cvrg	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing code at first report.
C
	PR_COML = RMISSD
	icovr = -1
C*
	IF  ( ERMISS (chc1) )  THEN
C
C*          Return with a missing value.
C
	  ELSE IF  ( chc1 .eq. 10000 )  THEN
C
C*	    Partially obscured conditions reported.
C
	    PR_COML = 9
C*
	  ELSE
C
C*	    Check for thin obscured combined with cloud height and
C*          coverage and get height code
C
	    IF  ( chc1 .gt. 10000 )  THEN
		ichc1 = INT (chc1) - 10000
	      ELSE
		ichc1 = INT (chc1)
	    END IF
	    ihght = ichc1 / 10
C
C*	    Check height against low-level limit.
C
	    IF  ( ihght .le. 63 )  THEN
	        PR_COML = chc1
	    	icovr = PR_CTCF ( FLOAT ( MOD ( ichc1, 10 ) ) )
	      ELSE IF  ( chc1 .gt. 10000 )  THEN
		PR_COML = 9
	    END IF
C
C*	    Check 2nd cloud report.
C
	    IF ( .not. ERMISS ( chc2 ) ) THEN
		ihght = INT ( chc2 ) / 10
	        icovx = PR_CTCF ( ( chc2 - FLOAT ( ihght * 10 ) ) )
		IF ( ihght .le. 63 .and. icovx .gt. icovr ) THEN
		    PR_COML = chc2
		    icovr = icovx
		END IF
	    END IF
C
C*	    Check 3rd cloud report.
C
	    IF ( .not. ERMISS ( chc3 ) ) THEN
		ihght = INT ( chc3 ) /10
	        icovx = PR_CTCF ( ( chc3 - FLOAT ( ihght * 10 ) ) )
		IF ( ihght .le. 63 .and. icovx .gt. icovr )
     +		    PR_COML = chc3
	    END IF
        END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      SUBROUTINE TSTIVF (WKID, INCSIZ,INCSET, EXCSIZ,EXCSET)

C  TSTIVF tests that the appropriate primitives are invisible for
C  a given inclusion and exclusion set used as the invisibility
C  filter.

C  Input parameters:
C    WKID          : workstation identifier
C    INCSIZ,INCSET : inclusion set
C    EXCSIZ,EXCSET : exclusion set

      INTEGER  WKID, INCSIZ,INCSET(*), EXCSIZ,EXCSET(*)
      INTEGER  TRUSIZ,TRULIS(8)

C  <set invisibility filter>:
      CALL PSIVFT (WKID, INCSIZ,INCSET, EXCSIZ,EXCSET)
C  Compute expected subset of invisible primitives from incl,excl
      CALL ELGPRM (INCSIZ,INCSET, EXCSIZ,EXCSET, TRUSIZ,TRULIS)

      CALL DLSTPF ('INVISIBILITY FILTER: Which primitives are ' //
     1             'invisible (n if none)?', TRUSIZ, TRULIS, 'S')

      END


SUBROUTINE inv_3x3(A,Ainv)
  IMPLICIT NONE
  REAL*8, intent(in)  :: A(3,3)
  REAL*8, intent(out) :: Ainv(3,3)
  ! locals
  REAL*8 :: det
  det = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)*A(3,2) &
      - A(3,1)*A(2,2)*A(1,3) - A(1,1)*A(3,2)*A(2,3) - A(2,1)*A(1,2)*A(3,3)
  Ainv(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  Ainv(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  Ainv(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  Ainv(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  Ainv(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  Ainv(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  Ainv(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  Ainv(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  Ainv(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE inv_3x3