text:
module mod_io
  use mpi_f08
  use mod_common, only: rp,MPI_REAL_RP,ierr
  private
  public load, load_scalar
contains
  subroutine load(io,filename,comm,myid,ng,nh,lo,hi,u,v,w,p,vof,us,vs,ws,tmp,sca,time,istep,pth,dpthdt_n)
    !
    ! reads/writes a restart file
    !
    implicit none
    character(len=1), intent(in) :: io
    character(len=*), intent(in) :: filename
    type(MPI_COMM)  , intent(in) :: comm
    integer         , intent(in) :: myid
    integer , intent(in), dimension(3) :: ng,nh,lo,hi
    real(rp), intent(inout), dimension(lo(1)-nh(1):,lo(2)-nh(2):,lo(3)-nh(3):) :: u,v,w,p,vof, &
                                                                                us,vs,ws,tmp,sca
    real(rp), intent(inout) :: time,pth,dpthdt_n!,dt
    integer , intent(inout) :: istep
    !real(rp), intent(out)    :: time,dt,pth,dpthdt_n
    !integer, intent(out)     :: istep
    !real(rp), dimension(5)  :: fldinfo
    type(MPI_FILE) :: fh
    !integer :: nreals_myid
    integer(kind=MPI_OFFSET_KIND) :: filesize,disp,good
    select case(io)
    case('r')
      call MPI_FILE_OPEN(comm, filename, &
           MPI_MODE_RDONLY, MPI_INFO_NULL,fh,ierr)
      !
      ! check file size first
      !
      call MPI_FILE_GET_SIZE(fh,filesize,ierr)
      good = (product(int(ng(:),MPI_OFFSET_KIND)))*(storage_size(1._rp)/8)
      if(filesize /= good) then
        if(myid == 0) print*, ''
        if(myid == 0) print*, '*** Simulation aborted due a checkpoint file with incorrect size ***'
        if(myid == 0) print*, '    file: ', filename, ' | expected size: ', good, '| actual size: ', filesize
        call MPI_FINALIZE(ierr)
        error stop
      end if
      !
      ! read
      !
      disp = 0_MPI_OFFSET_KIND
      if     (filename == 'data/fldu.bin')   then
      call io_field('r',fh,ng,nh,lo,hi,disp,u)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldv.bin')   then
      call io_field('r',fh,ng,nh,lo,hi,disp,v)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldw.bin')   then
      call io_field('r',fh,ng,nh,lo,hi,disp,w)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldp.bin')   then
      call io_field('r',fh,ng,nh,lo,hi,disp,p)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldvof.bin') then
      call io_field('r',fh,ng,nh,lo,hi,disp,vof)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldug.bin')  then
      call io_field('r',fh,ng,nh,lo,hi,disp,us)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldvg.bin')  then
      call io_field('r',fh,ng,nh,lo,hi,disp,vs)
      if(myid == 0) print*, 'file:', filename, 'read'

      elseif (filename == 'data/fldwg.bin')  then
      call io_field('r',fh,ng,nh,lo,hi,disp,ws)
      if(myid == 0) print*, 'file:', filename,  'read'

      elseif (filename == 'data/fldtmp.bin') then
      call io_field('r',fh,ng,nh,lo,hi,disp,tmp)
      if(myid == 0) print*, 'file:', filename,  'read'

      elseif (filename == 'data/fldsca.bin') then
      call io_field('r',fh,ng,nh,lo,hi,disp,sca)
      if(myid == 0) print*, 'file:', filename,  'read'

      endif

      call MPI_FILE_SET_VIEW(fh,disp,MPI_REAL_RP,MPI_REAL_RP,'native',MPI_INFO_NULL,ierr)
      !nreals_myid = 0
      !if(myid == 0) nreals_myid = 2
      !call MPI_FILE_READ(fh,fldinfo,nreals_myid,MPI_REAL_RP,MPI_STATUS_IGNORE,ierr)
      call MPI_FILE_CLOSE(fh,ierr)
      !call MPI_BCAST(fldinfo,2,MPI_REAL_RP,0,comm,ierr)
      !call MPI_BCAST(fldinfo,2,MPI_REAL_RP,0,comm,ierr)
      !time  = fldinfo(1)
      !istep = nint(fldinfo(2))
      !dt    = fldinfo(3)
      !pth   = fldinfo(4)
      !dpthdt_n = fldinfo(5)
    case('w')
      !
      ! write
      !
      call MPI_FILE_OPEN(comm, filename                 , &
           MPI_MODE_CREATE+MPI_MODE_WRONLY, MPI_INFO_NULL,fh,ierr)
      filesize = 0_MPI_OFFSET_KIND
      call MPI_FILE_SET_SIZE(fh,filesize,ierr)
      disp = 0_MPI_OFFSET_KIND

      disp = 0_MPI_OFFSET_KIND

      if     (filename == 'data/fldu_o.bin')   then
      call io_field('w',fh,ng,nh,lo,hi,disp,u)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldv_o.bin')   then
      call io_field('w',fh,ng,nh,lo,hi,disp,v)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldw_o.bin')   then
      call io_field('w',fh,ng,nh,lo,hi,disp,w)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldp_o.bin')   then
      call io_field('w',fh,ng,nh,lo,hi,disp,p)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldvof_o.bin') then
      call io_field('w',fh,ng,nh,lo,hi,disp,vof)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldug_o.bin')  then
      call io_field('w',fh,ng,nh,lo,hi,disp,us)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldvg_o.bin')  then
      call io_field('w',fh,ng,nh,lo,hi,disp,vs)
      if(myid == 0) print*, 'file:', filename, 'write'

      elseif (filename == 'data/fldwg_o.bin')  then
      call io_field('w',fh,ng,nh,lo,hi,disp,ws)
      if(myid == 0) print*, 'file:', filename,  'write'

      elseif (filename == 'data/fldtmp_o.bin') then
      call io_field('w',fh,ng,nh,lo,hi,disp,tmp)
      if(myid == 0) print*, 'file:', filename,  'write'

      elseif (filename == 'data/fldsca_o.bin') then
      call io_field('w',fh,ng,nh,lo,hi,disp,sca)
      if(myid == 0) print*, 'file:', filename,  'write'

      endif

      call MPI_FILE_SET_VIEW(fh,disp,MPI_REAL_RP,MPI_REAL_RP,'native',MPI_INFO_NULL,ierr)
      !fldinfo = [time,1._rp*istep,dt,pth,dpthdt_n]
      !nreals_myid = 0
      !if(myid == 0) nreals_myid = 2
      !call MPI_FILE_WRITE(fh,fldinfo,nreals_myid,MPI_REAL_RP,MPI_STATUS_IGNORE,ierr)
      call MPI_FILE_CLOSE(fh,ierr)
    end select
  end subroutine load

  subroutine load_scalar(io,filename,myid,pth,dpthdt_n,time,istep)
    !
    implicit none
    integer         , intent(in)    :: myid
    character(len=1), intent(in   ) :: io
    character(len=*), intent(in   ) :: filename
    real(8)         , intent(inout) :: pth,dpthdt_n
    integer         , intent(inout) :: istep
    real(8)         , intent(inout) :: time
    integer :: fh
    ! integer(kind=MPI_OFFSET_KIND) :: filesize,disp,good
    ! integer(8), dimension(3) :: ng
    ! integer(8) :: lenr
    !
    select case(io)
    case('r')
      open(88,file=filename,status='old',action='read')
      read(88,*) pth,dpthdt_n,time,istep
      close(88)
    case('w')
      if(myid.eq.0) then
        open(88,file=filename)
        !write(88,'(3E15.7, 1I9.8)') pth,dpthdt_n,time,istep
        write(88,'(3E15.7, 1I12.11)') pth,dpthdt_n,time,istep
        close(88)
      endif
    end select
    !
    return
  end subroutine load_scalar

  subroutine io_field(io,fh,ng,nh,lo,hi,disp,var)
    implicit none
    character(len=1), intent(in)                 :: io
    type(MPI_FILE)  , intent(in)                 :: fh
    integer         , intent(in), dimension(3)   :: ng,nh,lo,hi
    integer(kind=MPI_OFFSET_KIND), intent(inout) :: disp
    real(rp), intent(inout), dimension(lo(1)-nh(1):,lo(2)-nh(2):,lo(3)-nh(3):) :: var
    integer , dimension(3) :: n
    integer , dimension(3) :: sizes,subsizes,starts
    type(MPI_DATATYPE) :: type_glob,type_loc
    !
    n(:)        = hi(:)-lo(:)+1
    sizes(:)    = ng(:)
    subsizes(:) = n(:)
    starts(:)   = lo(:) - 1 ! starts from 0
    call MPI_TYPE_CREATE_SUBARRAY(3,sizes,subsizes,starts,MPI_ORDER_FORTRAN,MPI_REAL_RP,type_glob,ierr)
    call MPI_TYPE_COMMIT(type_glob,ierr)
    sizes(:)    = n(:) + 2*nh(:)
    subsizes(:) = n(:)
    starts(:)   = 0 + nh(:)
    call MPI_TYPE_CREATE_SUBARRAY(3,sizes,subsizes,starts,MPI_ORDER_FORTRAN,MPI_REAL_RP,type_loc ,ierr)
    call MPI_TYPE_COMMIT(type_loc,ierr)
    select case(io)
    case('r')
      call MPI_FILE_SET_VIEW(fh,disp,MPI_REAL_RP,type_glob,'native',MPI_INFO_NULL,ierr)
      call MPI_FILE_READ_ALL(fh,var,1,type_loc,MPI_STATUS_IGNORE,ierr)
    case('w')
      call MPI_FILE_SET_VIEW(fh,disp,MPI_REAL_RP,type_glob,'native',MPI_INFO_NULL,ierr)
      call MPI_FILE_WRITE_ALL(fh,var,1,type_loc,MPI_STATUS_IGNORE,ierr)
    end select
    disp = disp+product(int(ng(:),MPI_OFFSET_KIND))*(storage_size(1._rp)/8)
    call MPI_TYPE_FREE(type_glob,ierr)
    call MPI_TYPE_FREE(type_loc ,ierr)
  end subroutine io_field
end module mod_io

max_stars_repo_name: salarzs/interpolate-fields

max_issues_repo_name: salarzs/interpolate-fields

max_forks_repo_name: salarzs/interpolate-fields


text:
FUNCTION chebev_s(a,b,c,x)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: a,b,x
	REAL(SP), DIMENSION(:), INTENT(IN) :: c
	REAL(SP) :: chebev_s
	INTEGER(I4B) :: j,m
	REAL(SP) :: d,dd,sv,y,y2
	if ((x-a)*(x-b) > 0.0) call nrerror('x not in range in chebev_s')
	m=size(c)
	d=0.0
	dd=0.0
	y=(2.0_sp*x-a-b)/(b-a)
	y2=2.0_sp*y
	do j=m,2,-1
		sv=d
		d=y2*d-dd+c(j)
		dd=sv
	end do
	chebev_s=y*d-dd+0.5_sp*c(1)
END FUNCTION chebev_s

FUNCTION chebev_v(a,b,c,x)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: a,b
	REAL(SP), DIMENSION(:), INTENT(IN) :: c,x
	REAL(SP), DIMENSION(size(x)) :: chebev_v
	INTEGER(I4B) :: j,m
	REAL(SP), DIMENSION(size(x)) :: d,dd,sv,y,y2
	if (any((x-a)*(x-b) > 0.0)) call nrerror('x not in range in chebev_v')
	m=size(c)
	d=0.0
	dd=0.0
	y=(2.0_sp*x-a-b)/(b-a)
	y2=2.0_sp*y
	do j=m,2,-1
		sv=d
		d=y2*d-dd+c(j)
		dd=sv
	end do
	chebev_v=y*d-dd+0.5_sp*c(1)
END FUNCTION chebev_v

SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi)
	USE nrtype
	USE nr, ONLY : chebev
	IMPLICIT NONE
	REAL(DP), INTENT(IN) :: x
	REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi
	INTEGER(I4B), PARAMETER :: NUSE1=5,NUSE2=5
	REAL(SP) :: xx
	REAL(SP), DIMENSION(7) :: c1=(/-1.142022680371168_sp,&
		6.5165112670737e-3_sp,3.087090173086e-4_sp,-3.4706269649e-6_sp,&
		6.9437664e-9_sp,3.67795e-11_sp,-1.356e-13_sp/)
	REAL(SP), DIMENSION(8) :: c2=(/1.843740587300905_sp,&
		-7.68528408447867e-2_sp,1.2719271366546e-3_sp,&
		-4.9717367042e-6_sp, -3.31261198e-8_sp,2.423096e-10_sp,&
		-1.702e-13_sp,-1.49e-15_sp/)
	xx=8.0_dp*x*x-1.0_dp
	gam1=chebev(-1.0_sp,1.0_sp,c1(1:NUSE1),xx)
	gam2=chebev(-1.0_sp,1.0_sp,c2(1:NUSE2),xx)
	gampl=gam2-x*gam1
	gammi=gam2+x*gam1
END SUBROUTINE beschb_s

SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi)
	USE nrtype
	USE nr, ONLY : chebev
	IMPLICIT NONE
	REAL(DP), DIMENSION(:), INTENT(IN) :: x
	REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi
	INTEGER(I4B), PARAMETER :: NUSE1=5,NUSE2=5
	REAL(SP), DIMENSION(size(x)) :: xx
	REAL(SP), DIMENSION(7) :: c1=(/-1.142022680371168_sp,&
		6.5165112670737e-3_sp,3.087090173086e-4_sp,-3.4706269649e-6_sp,&
		6.9437664e-9_sp,3.67795e-11_sp,-1.356e-13_sp/)
	REAL(SP), DIMENSION(8) :: c2=(/1.843740587300905_sp,&
		-7.68528408447867e-2_sp,1.2719271366546e-3_sp,&
		-4.9717367042e-6_sp, -3.31261198e-8_sp,2.423096e-10_sp,&
		-1.702e-13_sp,-1.49e-15_sp/)
	xx=8.0_dp*x*x-1.0_dp
	gam1=chebev(-1.0_sp,1.0_sp,c1(1:NUSE1),xx)
	gam2=chebev(-1.0_sp,1.0_sp,c2(1:NUSE2),xx)
	gampl=gam2-x*gam1
	gammi=gam2+x*gam1
END SUBROUTINE beschb_v

max_stars_repo_name: ORNL-Fusion/KORC

max_issues_repo_name: ORNL-Fusion/KORC

max_forks_repo_name: ORNL-Fusion/KORC


text:
!***********************************************************************
!
      function relci_qed_F_Klarsfeld(n,kappa,Z)                   result(F)
!--------------------------------------------------------------------
! Estimates the function  F (Z*\alpha) by using a series expansion
! from S Klarsfeld and A Maquet, Physics Letters  43B (1973) 201,
! Eqs (1) and (2) and the table of Bethe logarithms. The
! vacuum-polarization contribution in Eq (2) is omitted.
! This procedure is adapted from RCI92 of GRASP92, written
! by Farid A Parpia, to the Fortran 95 standard.
!-----------------------------------------------
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
      !
      integer, intent(in)               :: n, kappa
      real(double), intent(in)         :: Z
      real(double)                     :: F
      !
      real(double), dimension(36), parameter :: bethe = &
         (/ 2.9841285_dp,   2.8117699_dp,  -0.0300167_dp,   2.7676636_dp, &
           -0.0381902_dp,  -0.0052321_dp,   2.7498118_dp,  -0.0419549_dp, &
           -0.0067409_dp,  -0.0017337_dp,   2.7408237_dp,  -0.0440347_dp, &
           -0.0076008_dp,  -0.0022022_dp,  -0.0007721_dp,   2.7356642_dp, &
           -0.0453122_dp,  -0.0081472_dp,  -0.0025022_dp,  -0.0009628_dp, &
           -0.0004079_dp,   2.7324291_dp,  -0.0461552_dp,  -0.0085192_dp, &
           -0.0027091_dp,  -0.0010945_dp,  -0.0004997_dp,  -0.0002409_dp, &
            2.7302673_dp,  -0.0467413_dp,  -0.0087850_dp,  -0.0028591_dp, &
           -0.0011904_dp,  -0.0005665_dp,  -0.0002904_dp,  -0.0001539_dp /)
      !
      real(double), parameter :: C401 = 11.0_dp/24.0_dp,                 &
                               C402 = 3.0_dp/8.0_dp, ovlfac = 4.0_dp/3.0_dp
      !
      integer       :: l, loc
      real(double) :: bethel, factor, term
      !
      ! Ensure that the principal quantum number is in range
      if (n < 1   .or.   n > 8) then
         print *, "Principal quantum number,",n,", should be in the range 1-8."
         stop     "relci_qed_F_Klarsfeld(): program stop A."
      end if
      !
      l = angular_momentum_l(kappa)
      if (l > n-1) then
         print *, "Kappa = ",kappa," is out of range for n = ",n,"."
         stop     "relci_qed_F_Klarsfeld(): program stop B."
      end if
      !
      ! Find the appropriate entry in the table
      loc    = (n*n-n)/2+l+1
      bethel = bethe(loc)
      !
      ! Determine the quantity in square brackets in eq.(1) of
      ! Klarsfeld and Maquet
      term = -bethel
      !
      if (kappa > 0) then
         term = term - c402 / (l*(l+l+one))
      else
         term = term + c402 / ((l+one)*(l+l+one))
         if (kappa == -1) then
            factor = log (Z/c)
            factor = - (factor + factor)
            term   = term + factor + c401
         end if
      end if
      !
      F = ovlfac * term
      !
   end function relci_qed_F_Klarsfeld

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
      SUBROUTINE KROD
C*****
C THIS ROUTINE COMPUTES THE TWO 6 X 6 MATRICES  K(NPVT,NPVT) AND
C K(NPVT,J) FOR A ROD HAVING END POINTS NUMBERED NPVT AND J.
C*****
C
C                        E C P T  F O R  T H E  R O D
C
C                                                                CARD
C                                                 TYPE   TABLE   TYPE
C ECPT( 1)ELEMENT ID.                               I     ECT    CROD
C ECPT( 2)SCALAR INDEX NUMBER FOR GRID POINT A      I     ECT    CROD
C ECPT( 3)SCALAR INDEX NUMBER FOR GRID POINT B      I     ECT    CROD
C ECPT( 4)MATERIAL ID.                              I     EPT    PROD
C ECPT( 5)AREA  (A)                                 R     EPT    PROD
C ECPT( 6)POLAR MOMENT OF INERTIA (J)               R     EPT    PROD
C ECPT( 7) TORSIONAL STRESS COEFF (C)                R    EPT    PROD
C ECPT( 8) NON-STRUCTRAL MASS (MU)                   R    EPT    PROD
C ECPT( 9) COOR. SYS. ID. NO. FOR GRID POINT A       I   BGPDT   GRID
C ECPT(10) X-COORDINATE OF GRID PT. A (IN BASIC COOR)R   BGPDT
C ECPT(11) Y-COORDINATE OF GRID PT. A (IN BASIC COOR)R   BGPDT
C ECPT(12) Z-COORDINATE OF GRID PT. A (IN BASIC COOR)R   BGPDT
C ECPT(13) COOR. SYS. ID. NO. FOR GRID POINT B       I   BGPDT
C ECPT(14) X-COORDINATE OF GRID PT. B (IN BASIC COOR)R   BGPDT
C ECPT(15) Y-COORDINATE OF GRID PT. B (IN BASIC COOR)R   BGPDT
C ECPT(16) Z-COORDINATE OF GRID PT. B (IN BASIC COOR)R   BGPDT
C ECPT(17) ELEMENT TEMPERATURE
C
      LOGICAL  HEAT
C
      DOUBLE PRECISION
     1                   X                  ,Y
     2,                  Z                  ,XL
     3,                  XN                 ,DSCL
     4,                  DSCR               ,DAMPC
     5,                  D                  ,KE
     6,                  TI                 ,DUMDP
C
      DIMENSION
     1                   IECPT(4)
      COMMON /BLANK/ICOM
      COMMON   /SYSTEM/
     1                   ISYS
C
C SMA1 I/O PARAMETERS
C
      COMMON   /SMA1IO/
     1                   IFCSTM             ,IFMPT
     2,                  IFDIT              ,IDUM1
     3,                  IFECPT             ,IGECPT
     4,                  IFGPCT             ,IGGPCT
     5,                  IFGEI              ,IGGEI
     6,                  IFKGG              ,IGKGG
     7,                  IF4GG              ,IG4GG
     8,                  IFGPST             ,IGGPST
     9,                  INRW               ,OUTRW
     T,                  CLSNRW             ,CLSRW
     1,                  NEOR               ,EOR
     2,                  MCBKGG(7)          ,MCB4GG(7)
C
C SMA1 VARIABLE CORE BOOKKEEPING PARAMETERS
C
      COMMON   /SMA1BK/
     1                   ICSTM              ,NCSTM
     2,                  IGPCT              ,NGPCT
     3,                  IPOINT             ,NPOINT
     4,                  I6X6K              ,N6X6K
     5,                  I6X64              ,N6X64
C
C SMA1 PROGRAM CONTROL PARAMETERS
C
      COMMON   /SMA1CL/
     1                   IOPT4              ,K4GGSW
     2,                  NPVT               ,LEFT
     3,                  FROWIC             ,LROWIC
     4,                  NROWSC             ,TNROWS
     5,                  JMAX               ,NLINKS
     6,                  LINK(10)           ,IDETCK
     7,                  DODET              ,NOGO
      COMMON/SMA1HT/     HEAT
C
C ECPT COMMON BLOCK
C
      COMMON   /SMA1ET/
     1                   ECPT(17)           ,DUMET(83)
C
C INPUT AND OUTPUT BLOCKS FOR SUBROUTINE MAT
C
      COMMON   /MATIN/
     1                   MATIDC             ,MATFLG
     2,                  ELTEMP             ,STRESS
     3,                  SINTH              ,COSTH
      COMMON   /MATOUT/
     1                   E                  ,G
     2,                  NU                 ,RHO
     3,                  ALPHA              ,TSUBO
     4,                  GSUBE              ,SIGT
     5,                  SIGC               ,SIGS
      COMMON/HMTOUT/     FK
C
C LOCAL DOUBLE PRECISION VARIABLES
C
      COMMON   /SMA1DP/
     1                   X                  ,Y
     2,                  Z                  ,XL
     3,                  XN(3)              ,DSCL
     4,                  DSCR               ,DAMPC
     5,                  D(18)              ,KE(36)
     6,                  TI(9)              ,DUMDP(227)
C
C
C NOTE THAT EQUIVALENCE IS NECESSARY SINCE ECPT IS A MIXED --- INTEGERS
C AND REAL --- ARRAY
C
      EQUIVALENCE
     1                   (IECPT(1),ECPT(1))
C*****
C  BRANCH ON HEAT FORMULATION.
C*****
      IF( HEAT ) GO TO 200
      IF (IECPT(2) .EQ. NPVT) GO TO 10
      IF (IECPT(3) .NE. NPVT) CALL MESAGE (-30,34,IECPT(1))
      ITEMP = IECPT(2)
      IECPT(2) = IECPT(3)
      IECPT(3) = ITEMP
      KA  = 13
      KB  =  9
      GO TO 20
   10 KA  =  9
      KB  =  13
C
C AT THIS POINT KA POINTS TO THE COOR. SYS. ID. OF THE PIVOT GRID POINT.
C SIMILARLY FOR KB AND THE NON-PIVOT GRID POINT.
C NOW COMPUTE THE LENGTH OF THE ROD.
C
C WE STORE THE COORDINATES IN THE D ARRAY SO THAT ALL ARITHMETIC WILL BE
C DOUBLE PRECISION
C
   20 D(1) = ECPT(KA+1)
      D(2) = ECPT(KA+2)
      D(3) = ECPT(KA+3)
      D(4) = ECPT(KB+1)
      D(5) = ECPT(KB+2)
      D(6) = ECPT(KB+3)
      X    = D(1) - D(4)
      Y    = D(2) - D(5)
      Z    = D(3) - D(6)
      XL = DSQRT (X**2 + Y**2 + Z**2)
      IF (XL.NE.0.0D0) GO TO 30
      CALL MESAGE(30,26,IECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO ACCUMULA
C
      NOGO=1
      RETURN
   30 CONTINUE
C
C CALCULATE A NORMALIZED DIRECTION VECTOR IN BASIC COORDINATES.
C
      XN(1) = X / XL
      XN(2) = Y / XL
      XN(3) = Z / XL
C
C LOCATE E = YOUNG-S MODULUS, G = SHEAR MODULUS AND DAMPC = DAMPING
C CONSTANT IN THE MAT1 TABLE AND COMPUTE DSCL = A * E / XL AND
C DSCR = J * G / XL.  A IS ECPT(5) AND J IS ECPT(6)
C
      MATIDC = IECPT(4)
      MATFLG = 1
      ELTEMP = ECPT(17)
      CALL MAT (IECPT(1))
C
C WE STORE ECPT(5), ECPT(6), E AND G IN DOUBLE PRECISION LOCATIONS SO
C THAT ALL ARITHMETIC WILL BE DOUBLE PRECISION
C
      D(1) = ECPT(5)
      D(2) = E
      D(3) = ECPT(6)
      D(4) = G
      DSCL = D(1) * D(2) / XL
      DSCR = D(3) * D(4) / XL
      DAMPC  = G SUB E
C
C SET UP THE -N- MATRIX AND STORE AT D(1)
C
      D(1) = XN(1) * XN(1)
      D(2) = XN(1) * XN(2)
      D(3) = XN(1) * XN(3)
      D(4) = D(2)
      D(5) = XN(2) * XN(2)
      D(6) = XN(2) * XN(3)
      D(7) = D(3)
      D(8) = D(6)
      D(9) = XN(3) * XN(3)
C
C ZERO OUT THE 6X6 WHICH WILL BE USED FOR STORAGE OF KGG(NPVT,NONPVT),
C NONPVT = NPVT,J
C KGG(NPVT,NONPVT), NONPVT = NPVT,J
C
      DO 50 I = 1,36
   50 KE(I) = 0.0D0
      NONPVT = 2
      K2 = 1
C
C IF PIVOT GRID POINT IS IN BASIC COORDINATES, GO TO 70
C
      IF (IECPT(KA) .EQ. 0) GO TO 70
      CALL TRANSD (ECPT(KA),TI(1))
      CALL GMMATD (TI(1),3,3,1, D(1),3,3,0, D(10))
      CALL GMMATD (D(10),3,3,0, TI(1),3,3,0, D(1))
C
C AT THIS POINT D(1) CONTAINS THE MATRIX PRODUCT TAT * N * TA
C AND D(10) CONTAINS THE MATRIX PRODUCT TAT * N.
C
      ASSIGN 100 TO IRETRN
      GO TO 80
   70 ASSIGN 90 TO IRETRN
C
C FILL THE KE MATRIX
C
   80 KE( 1) = DSCL * D(K2  )
      KE( 2) = DSCL * D(K2+1)
      KE( 3) = DSCL * D(K2+2)
      KE( 7) = DSCL * D(K2+3)
      KE( 8) = DSCL * D(K2+4)
      KE( 9) = DSCL * D(K2+5)
      KE(13) = DSCL * D(K2+6)
      KE(14) = DSCL * D(K2+7)
      KE(15) = DSCL * D(K2+8)
      KE(22) = DSCR * D(K2  )
      KE(23) = DSCR * D(K2+1)
      KE(24) = DSCR * D(K2+2)
      KE(28) = DSCR * D(K2+3)
      KE(29) = DSCR * D(K2+4)
      KE(30) = DSCR * D(K2+5)
      KE(34) = DSCR * D(K2+6)
      KE(35) = DSCR * D(K2+7)
      KE(36) = DSCR * D(K2+8)
      CALL SMA1B (KE,ECPT(NONPVT),-1,IFKGG,0.0D0)
      IF (IOPT4 .EQ. 0  .OR.  G SUB E .EQ. 0.0) GO TO 85
      K4GGSW = 1
      CALL SMA1B (KE,ECPT(NONPVT),-1,IF4GG,DAMPC)
C
C  RETURN  FROM  FILL  CODE W/ IRETRN = 90 IMPLIES G.P. A WAS IN BASIC
C    .      .     .      .      .     =100 IMPLIES G.P. A WAS NOT BASIC
C    .      .     .      .      .     =140 IMPLIES THE K(NPVT,NONPVT)
C                                      HAS BEEN COMPUTED AND INSERTED
C                                      AND HENCE WE ARE FINISHED.
C
   85 GO TO IRETRN , (90,100,140)
   90 K1 = 1
      K2 = 10
      GO TO 110
  100 K1 = 10
      K2 = 1
  110 NONPVT = 3
C
C IF NON-PIVOT GRID POINT IS IN BASIC COORDINATES, GO TO 120
C
      IF (IECPT(KB) .EQ. 0) GO TO 120
      CALL TRANSD (ECPT(KB),TI(1))
C
C RECALL THAT D(K1) CONTAINS TAT * N.
C
      CALL GMMATD (D(K1),3,3,0, TI(1),3,3,0, D(K2))
C
C AT THIS POINT D(K2) CONTAINS TAT * N * TB.
C
      GO TO 130
  120 K2 = K1
  130 ASSIGN 140 TO IRETRN
C
C SET CONSTANTS NEGATIVE TO PROPERLY COMPUTE K(NPVT,NONPVT)
C
      DSCR = -DSCR
      DSCL = -DSCL
      GO TO 80
C
C A TRANSFER TO STATEMENT NO. 140 IMPLIES KGG AND/OR K4GG CALCULATIONS
C HAVE BEEN COMPLETED.
C
  140 RETURN
C*****
C  HEAT FORMULATION.  FIRST COMPUTE LENGTH OF ELEMENT.
C*****
  200 X = ECPT(14) - ECPT(10)
      Y = ECPT(15) - ECPT(11)
      Z = ECPT(16) - ECPT(12)
      XL= DSQRT(X**2 + Y**2 + Z**2)
      IF( XL ) 300,300,400
  300 CALL MESAGE( -30, 26, IECPT(1) )
C
C     GET MATERIAL PROPERTY -K- FROM HMAT ROUTINE
C
  400 MATFLG = 1
      MATIDC = IECPT(4)
      ELTEMP = ECPT(17)
      CALL HMAT( IECPT )
C
      XL = DBLE(FK) * DBLE(ECPT(5)) / XL
C
      IF( NPVT .EQ. IECPT(3) ) XL = -XL
      DO 700 I = 1,2
      CALL SMA1B( XL, IECPT(I+1), NPVT, IFKGG, 0.0D0 )
      XL = -XL
  700 CONTINUE
      RETURN
      END

ext: f


text:
Please note  Lily is not currently seeing clients . She highly recommends the massage therapy of Mereb Habtetsion, LMT  Deep Tissue Massage Therapy Mereb Habtetsion, CMT and Eloisa Flores, CMP  Massage and Body Wraps Eloisa Flores, CMP, available at the same location and on the same online scheduler.

Lily Starling grew up in the Davis area and is back in town after 13 years away.

Lily specializes in Deep Tissue and Deep Swedish massage, but also understands that not everyone needs deep work at all times. Sometimes we all need a lighter touch when our nervous systems are fried from a long week. Her list of services, prices, and online scheduling can be accessed at her webpage (just follow the link above). Additionally, if you are interested in exploring a therapy that gently treats trauma to the central nervous system, consider booking a craniosacral therapy session.

Lily attended Heartwood Institute of Massage, a renowned healing program in California. Started as a social experiment in the late 60s, the Heartwood community organized in the following decades around massage therapy and Asian healing arts training. It is now known as one of the most intensive and prestigious certification programs for massage, nutrition, and wellness. She completed 780 hours of training over 9 months. Last year she went to Thailand to study the Royal Traditional style of Thai Massage. Next on her continuing education agenda is Mayan abdominal massage in Belize, where she lived from age 2022.

Mereb Habtetsion, LMT  Deep Tissue Massage Therapy Mereb Habtetsion, CMT and Eloisa Flores, CMP  Massage and Body Wraps Eloisa Flores, CMP  work with Lily in her business, Downtown Davis Massage and Wellness.

Mereb and Eloisa offer student discounts of 15% off per massage.

Gift certificates are available for purchase online.

Recommended complementary health providers:

Chiropractic: Active Family & Sports Chiropractic Dr. Michelle Chu, Active Family and Sports Chiropractic
Physical Therapy: Jason Marvin, PT (916) 9525911
Acupuncture: Davis Community Acupuncture Clinic Itay Neta, LAc
Yoga: Kaya Yoga and FIT House Power Vinyasa Yoga
Personal Training: Lisa Herrington, FIT House (530) 2198459
Pilates: Lift Pilates

  From therapy to pure relaxation, Davis offers a variety of Massage Services

20110418 20:18:44 nbsp I love a good massage, but in reality _GOOD_ massages are hard to find.  Look no further  Lily provides an awesome massage. I went through a number of other therapists before finding Lily and I havent seen anyone else since.  I enjoy doing physical things that beat up my body and thus tend to really like deep massages that work out tight knots and deep spasms and break up scar tissue. Lily is not afraid to put the pressure on high when it is required, but at the same time she strikes a nice balance between that perfect deep tissue massage and providing an extremely relaxing and calming overall experience. I always leave feeling relaxed, refreshed and 10 times better than when I walked in. On top of that, Lily is really friendly and an awesome person and so overall shes pretty hard to beat. I cant recommend her highly enough so go ahead and check out her work for yourself. Users/SteveSchwortz

20110421 22:39:13 nbsp Lily is fantastic. I havent had too many massages but of the few, her massage was the best. Nice location, relaxing atmosphere, and great massage. Lily is super friendly and accommodating as well. Plus, she has evening times available and a discounted student rate  yay! Try her out. Users/ChristyMarsden

20110423 18:54:29 nbsp Thank you for the positive feedback! Davis is a very supportive community for massage therapy and complementary alternative medicine practices in general. Im happy to be part of the gang! Id also like to thank Ernest Maningding for reaching out to me via the wiki and asking me to speak at Filipino Association of Health Careers on campus last week. It was a lot of fun and a great example of Daviswiki putting people in the community more in touch with each other. Users/LilyS

20110501 12:31:33 nbsp Im not kidding when I say that Lilys hour and a half hot stone massage added YEARS to my life... It was one of the single greatest and most relaxing experiences of I have ever had.  The only bad part when I had to leave her massage table and go back to my life.  I wanted to just lie there forever.  I have been going to Lily for a long time but never indulged in the extra long massage with hot stones before.  Boy, was I missing out until now!  I have since become a convert and will do nothing less for myself than the 90 minute hot stone massage!!! Do your self a giant awesome favor and book now, you and your body will not regret it!  She is absolutely the BEST massage therapist I have ever been to! Thanks Lily! Users/dina2901

20110508 08:12:41 nbsp I have been getting professional massages for many, many years and most of them have been great, but when I went to Lily the first time (a few years ago) I was so impressed. She really knows what she is doing. She can do massages to get rid of migraine headaches, she can relieve and help prevent sciatica, she can just give you a total feel good, pleasure massage if that is what you need. Her space is beautiful and calming, and you can tell you are in good hands, that know what they are doing.   Users/DjinaAriel

20110519 09:49:07 nbsp As a second year veterinary student my neck and shoulders are a constant mess of tense muscles and knots. I have been to several massage therapists in the area and was REALLY impressed with Lily. After a one hour massage my tension headache subsided and I could sleep again. I found that Lily has the ability to find and relieve points of tension, while still providing a very calming massage. The practice was clean, professional and relaxing. Furthermore Lily offers a great student discount ($60/hr)! Overall I would highly recommend Lily Starling as a massage therapist. Users/EmilyFyfe

20110617 14:15:03 nbsp I just had my first massage (ever) from Lily and it was fantastic!  Thank you!!! Users/JustinLowenthal

20110618 20:04:22 nbsp A wonderful experience with a truly talented massage therapist. I highly recommend Lily to anyone who is looking for a deeply relaxing and revitalizing massage. Great location with a soothing atmosphere as well! Users/KMassoudi

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
ChoadBot is the penultimate electrotrash band.  Choad Bot was based in Davis and is:
   Harry Choad  Guitar/Fashismo
   Users/GarrettPierce Berry Choad  Singing/Guitar/Prancing/Large Balls
   DanMacht RICHARD  Male Model/Mirrors
   Choadette  Hot Sex/Keyboards
   GregHagel Gregtron  Perversion
   Bafoid  Roboflux beats

http://www.livejournal.com/community/honorarypirates/1228.html Photos of Choadbot live at the Pirate Ship on Halloween

Here is what Users/RobRoy has to say about ChoadBot (from Friendster):

  When I talked to people about ChoadBot I say, Fuck what you heard. Believe the hype. Because they are a hyped up band and even though it seems like an oxymoron the hype is honest. When I saw them I nearly died. Not because I started screaming so load that in comparison Beatlemania would feel like an afternoon on Cspan but because I nearly suffocated from all the hot sex in the room. And when Berry Choad nearly killed himself when he started breaking every bone in his body he was a Christ like figure. I kept chanting What would Iggy Pop do. And he did what Iggy Pop would do. He grabbed a few innocent audience members and shoved so much hot sex into their orifices that the floor became wet with puddles of joyful urine.

Also, a review by the Dam Haus (Friendster):

  I think the Guiness Book of World Records should contain an entry for The most cliches incorporated into one band: Choadbot (sunglasses at night, rolling around on broken glass, instrument switcheroos, girl in slinky dress playing keyboards, lotsa stripping and nipplerubbing, taking forever to set up, trying to make everyone clap to the beat, boys in makeup, and the newest rock cliche and certainly the most ingenious, a lead singer in a bathrobe and Tevas. It was especially funny that after their hourlong seven song set at Plainfield Station, they offered CDRs for sale with one song on it, and admitted, Its actually our only song. If you havent seen ChoadBot, be ready to hear the word choad more times in one hour than youve ever heard it in all your life.

CM Caskey of The California Aggie and Filthy Pete and the Moustaches said that ChoadBot was the http://www.californiaaggie.com/media/storage/paper981/news/2005/01/06/Features/YourFavourite.local.Band.Sucks1319087.shtml?norewrite200606071906&sourcedomainwww.californiaaggie.com worst band in Davis:

  Every once in a while this group of respectable local musicians from decent bands dresses up in womens underwear and turns into what they call an electroclash band. Ironically, theyre not electroclash. Theyre also not very good. Yeah, I know its not serious. Yeah, I know its a joke. Haha, very funny. It still sucks.

ChoadBot played their last Davis show at the Pirate Ship on Jan 9th, 2005.

On March 1st, 2005, ChoadBot performed their final show at 12 Galaxies in San Francisco.  At the end of the show the band members fell to the ground one by one.  Except for Bafoid, who exclaimed, ChoadBot is dead.  In Berry Choads final words to the audience before he died, he expressed a sincere hope that every member of the audience will have sex later that night, in the name of ChoadBot.

On April 23rd, 2006, Choadbot returned from the dead to play at Delta of Venus.


text:
	SUBROUTINE IN_INTC  ( cint, gmin, gmax, cval, nv, clbl,
     +                        rint, cmin, cmax, iret )
C************************************************************************
C* IN_INTC								*
C*									*
C* This subroutine processes the user contour specification.  GMIN and 	*
C* GMAX are input as the mininum and maximum values in the grid.  	*
C* For loops, this routine is called only once for the first pixmap.	*
C* The list of contour levels is returned in CVAL, along with CMIN and 	*
C* CMAX, the minimum and maximum to be contoured.  			*
C* 									*
C* CINT is expected to be of the form:					*
C*									*
C*	    increment/minimum/maximum/ndigits				*
C*    or								*
C*          value1;value2;...;valueN///ndigits				*
C*    or								*
C*	    value1=label1;value2=label2;...;valueN=labelN		*
C*									*
C* where the minimum and maximum give the range for the contours. If	*
C* the minimum equals the maximum, a single contour with that value	*
C* is assumed.  In the latter specification, the specified contour	*
C* levels are used, and the minimum and maximum are ignored.		*
C* The fourth parameter, ndigits, forces all labels with fewer than	*
C* ndigits digits in the integer portion of the label to expand to	*
C* ndigits by padding the leading digit with zeroes.			*
C*									*
C* IN_INTC  ( CINT, GMIN, GMAX, CVAL, NV, CLBL, RINT, CMIN, CMAX, 	*
C*	      IRET )							*
C*									*
C* Input parameters:							*
C*	CINT		CHAR*		Input for contours		*
C*	GMIN		REAL		Minimum grid value		*
C*	GMAX		REAL		Maximum grid value		*
C*									*
C* Output parameters:							*
C*	CVAL (*)	REAL		List of contour levels		*
C*	NV		INTEGER		Number of contour levels	*
C*	CLBL (*)	CHAR*		Contour labels			*
C*	RINT		REAL		Calculated contour interval	*
C*	CMIN		REAL		Contour minimum			*
C*	CMAX		REAL		Contour maximum			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -3 = invalid input		*
C**									*
C* Log:									*
C* P. Bruehl/Unidata	08/94	Based on IN_CINT, now returns CMIN,CMAX	*
C* T. Piper/GSC		11/98	Updated prolog				*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C* T. Lee/SAIC		12/01	Increased substr string length to LLMXLN*
C* C. Bailey/HPC	 6/06	Modified to return contour labels	*
C* S. Jacobs/NCEP	11/06	Fixed bug when min=max			*
C* R. Jones/NCEP        12/06   Added number of digits specification    *
C* S. Schotz/NCEP	2/07	Correct case where no cint is set	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	cint
	REAL		cval (*)
	CHARACTER*(*)	clbl (*)
C*
	CHARACTER	substr (4) * (LLMXLN), cname (LLCLEV)*24,
     +			carr(2)*24
        CHARACTER       clab1*24, clab2*24
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C
C*  Initialize output parameters
C
	nv = 0
	rint = RMISSD
	cmin = RMISSD
	cmax = RMISSD
	iret = 0
C
C*	Break CINT into 4 substrings.
C
	CALL ST_CLST ( cint, '/', ' ', 4, substr, nst, ier )
	IF  ( ier .ne. 0 )  THEN
	    iret = -3
	    CALL ER_WMSG ( 'IN', iret, cint, ier )
	    RETURN
	END IF
C
C*	Convert the fourth item to an integer. Check for valid values
C*	for the number of leading zeroes to be added to a data value.
C
	CALL ST_NUMB ( substr (4), npad, ier )
	IF  ( ( npad .lt. 0 ) .or. ( npad .gt. 9 ) )  npad = 0
C
C*	Look at the first substring to see if it contains a list of
C*	values or a single number giving the increment.
C
	CALL ST_CLST ( substr (1), ';', ' ', LLCLEV, cname, nv, ier )
	IF  ( ier .ne. 0 )  THEN
	    iret = -3
	    CALL ER_WMSG ( 'IN', iret, cint, ier )
	END IF
C
C	Check for case where no contour interval is specified
C
	IF (nv .eq. 0) THEN
C
C	    Initilize contour interval when not specified
C
	    cval(1) = 0.0
	ELSE
C
C*          Loop through each contour value
C
	    DO i = 1, nv
C
C*	        Separate contour value from label if appropriate
C
	        CALL ST_CLST ( cname (i), '=', ' ', 2, carr, num, ier )
C
C*	        Convert contour value string into a real number
C
	        CALL ST_CRNM(carr(1), rnum, ier )
	        cval(i) = rnum
C
C*	        Check to see if contour label specified with value.
C*	        If not, use contour value as label
C
	        IF (num .gt. 1) then
	      	    clbl(i) = carr(2)
	        ELSE
		    clbl(i) = carr(1)
	        END IF
	    END DO
	END IF
C
	IF ( nv .gt. 1 ) THEN
	    rint = 0.0
	    cmin = 0.0
	    cmax = 0.0
	  ELSE
C
C*	    Contour levels have not been listed.
C*	    Decode range from second and third substrings.
C
	    CALL ST_CRNM ( substr (2), cmin, ier )
	    CALL ST_CRNM ( substr (3), cmax, ier )
C
C*	    Check for single contour level.
C
	    IF ( cmin .eq. cmax .and. .not. ERMISS ( cmin ) ) THEN
C
C*		Check if label has been specified, if not set cval(1)
C*		and contour label to cmin
C
	        cval (1) = cmin
		IF (num .le. 1) then
		    CALL GR_LABL(cval(1), 0, 0, clbl(1), nchar, ier)
		END IF
		rint = 0.0
		nv   = 1
	      ELSE
C
C*		Generate multiple contour levels.
C*		Specified contour label strings not allowed.
C
		rcint = cval (1)
		CALL GR_CLVL ( LLCLEV, cmin, cmax, rcint, gmin, gmax,
     +				nv, cval, rint, iret )
		IF ( iret .ne. 0 )  THEN
		    CALL ER_WMSG ( 'GR', iret, ' ', ier )
		    iret = -3
		    CALL ER_WMSG ( 'IN', iret, ' ', ier )
		    RETURN
		END IF
C
C*		Convert contour values to strings
C
		DO i = 1, nv
		    CALL GR_LABL(cval(i), 0, 0, clbl(i), nchar, ier)
		END DO
	    END IF
	END IF
C
C*	Add zero-padding to the contour values.
C
	IF  ( npad .gt. 0 )  THEN
	    DO  ii = 1, nv
		CALL ST_NULL ( clbl(ii), clab1, lenc, ier )
		CALL CST_ZPAD ( clab1, npad, clab2, ier )
		CALL ST_RNUL ( clab2, clbl(ii), lenc, ier )
	    END DO
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
!     -*- Mode: Fortran; -*-
!  (C) 2008 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
       MODULE MPI_BASE
       IMPLICIT NONE
!      This module was created by the script buildiface
       INTERFACE
      SUBROUTINE MPI_TYPE_CREATE_DARRAY(size,rank,ndims,array_of_gsizes,&
                  array_of_distribs,array_of_dargs,array_of_psizes,order,&
                  oldtype,newtype,ierror)
           INTEGER size
           INTEGER rank
           INTEGER ndims
           INTEGER array_of_gsizes(*)
           INTEGER array_of_distribs(*)
           INTEGER array_of_dargs(*)
           INTEGER array_of_psizes(*)
           INTEGER order
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_DARRAY

      SUBROUTINE MPI_TYPE_EXTENT(datatype,extent,ierror)
           INTEGER datatype
           INTEGER extent
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_EXTENT

      SUBROUTINE MPI_TYPE_GET_NAME(datatype,type_name,resultlen,ierror)
           INTEGER datatype
           CHARACTER (LEN=*) type_name
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_NAME

      SUBROUTINE MPI_WIN_LOCK(lock_type,rank,assert,win,ierror)
           INTEGER lock_type
           INTEGER rank
           INTEGER assert
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_LOCK

      SUBROUTINE MPI_COMM_SPLIT(comm,color,key,newcomm,ierror)
           INTEGER comm
           INTEGER color
           INTEGER key
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SPLIT

      SUBROUTINE MPI_WIN_COMPLETE(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_COMPLETE

      SUBROUTINE MPI_GROUP_SIZE(group,size,ierror)
           INTEGER group
           INTEGER size
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_SIZE

      SUBROUTINE MPI_FILE_GET_ERRHANDLER(file,errhandler,ierror)
           INTEGER file
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_FILE_GET_ERRHANDLER

      SUBROUTINE MPI_REQUEST_FREE(request,ierror)
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_REQUEST_FREE

      SUBROUTINE MPI_TYPE_CREATE_HINDEXED_BLOCK(count,blocklength,&
                  array_of_displacements,oldtype,newtype,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER count
           INTEGER blocklength
           INTEGER(KIND=MPI_ADDRESS_KIND) array_of_displacements(*)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_HINDEXED_BLOCK

      SUBROUTINE MPI_BARRIER(comm,ierror)
           INTEGER comm
           INTEGER ierror
      END SUBROUTINE MPI_BARRIER

      SUBROUTINE MPI_TYPE_COMMIT(datatype,ierror)
           INTEGER datatype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_COMMIT

      SUBROUTINE MPI_GROUP_RANGE_EXCL(group,n,ranges,newgroup,ierror)
           INTEGER group
           INTEGER n
           INTEGER ranges(3,*)
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_RANGE_EXCL

      SUBROUTINE MPI_REQUEST_GET_STATUS(request,flag,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER request
           LOGICAL flag
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_REQUEST_GET_STATUS

      SUBROUTINE MPI_COMM_SPAWN_MULTIPLE(count,array_of_commands,array_of_argv,&
                  array_of_maxprocs,array_of_info,root,comm,intercomm,&
                  array_of_errcodes,ierror)
           INTEGER count
           CHARACTER (LEN=*) array_of_commands(*)
           CHARACTER (LEN=*) array_of_argv(count,*)
           INTEGER array_of_maxprocs(*)
           INTEGER array_of_info(*)
           INTEGER root
           INTEGER comm
           INTEGER intercomm
           INTEGER array_of_errcodes(*)
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SPAWN_MULTIPLE

      SUBROUTINE MPI_TYPE_GET_EXTENT(datatype,lb,extent,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER datatype
           INTEGER(KIND=MPI_ADDRESS_KIND) lb
           INTEGER(KIND=MPI_ADDRESS_KIND) extent
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_EXTENT

      SUBROUTINE MPI_INFO_GET_VALUELEN(info,key,valuelen,flag,ierror)
           INTEGER info
           CHARACTER (LEN=*) key
           INTEGER valuelen
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_INFO_GET_VALUELEN

      SUBROUTINE MPI_OP_CREATE(user_fn,commute,op,ierror)
           EXTERNAL user_fn
           LOGICAL commute
           INTEGER op
           INTEGER ierror
      END SUBROUTINE MPI_OP_CREATE

      SUBROUTINE MPI_TYPE_CREATE_STRUCT(count,array_of_blocklengths,&
                  array_of_displacements,array_of_types,newtype,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER count
           INTEGER array_of_blocklengths(*)
           INTEGER(KIND=MPI_ADDRESS_KIND) array_of_displacements(*)
           INTEGER array_of_types(*)
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_STRUCT

      SUBROUTINE MPI_WIN_GET_GROUP(win,group,ierror)
           INTEGER win
           INTEGER group
           INTEGER ierror
      END SUBROUTINE MPI_WIN_GET_GROUP

      SUBROUTINE MPI_GROUP_COMPARE(group1,group2,result,ierror)
           INTEGER group1
           INTEGER group2
           INTEGER result
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_COMPARE

      SUBROUTINE MPI_CART_SHIFT(comm,direction,disp,rank_source,rank_dest,&
                  ierror)
           INTEGER comm
           INTEGER direction
           INTEGER disp
           INTEGER rank_source
           INTEGER rank_dest
           INTEGER ierror
      END SUBROUTINE MPI_CART_SHIFT

      SUBROUTINE MPI_COMM_GROUP(comm,group,ierror)
           INTEGER comm
           INTEGER group
           INTEGER ierror
      END SUBROUTINE MPI_COMM_GROUP

      SUBROUTINE MPI_WIN_CALL_ERRHANDLER(win,errorcode,ierror)
           INTEGER win
           INTEGER errorcode
           INTEGER ierror
      END SUBROUTINE MPI_WIN_CALL_ERRHANDLER

      SUBROUTINE MPI_LOOKUP_NAME(service_name,info,port_name,ierror)
           CHARACTER (LEN=*) service_name
           INTEGER info
           CHARACTER (LEN=*) port_name
           INTEGER ierror
      END SUBROUTINE MPI_LOOKUP_NAME

      SUBROUTINE MPI_INFO_FREE(info,ierror)
           INTEGER info
           INTEGER ierror
      END SUBROUTINE MPI_INFO_FREE

      SUBROUTINE MPI_GRAPH_GET(comm,maxindex,maxedges,indx,edges,ierror)
           INTEGER comm
           INTEGER maxindex
           INTEGER maxedges
           INTEGER indx(*)
           INTEGER edges(*)
           INTEGER ierror
      END SUBROUTINE MPI_GRAPH_GET

      SUBROUTINE MPI_STATUS_SET_ELEMENTS(status,datatype,count,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER datatype
           INTEGER count
           INTEGER ierror
      END SUBROUTINE MPI_STATUS_SET_ELEMENTS

      SUBROUTINE MPI_COMM_SET_INFO(comm,info,ierror)
           INTEGER comm
           INTEGER info
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SET_INFO

      SUBROUTINE MPI_WIN_FREE(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FREE

      SUBROUTINE MPI_PACK_EXTERNAL_SIZE(datarep,incount,datatype,size,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           CHARACTER (LEN=*) datarep
           INTEGER incount
           INTEGER datatype
           INTEGER(KIND=MPI_ADDRESS_KIND) size
           INTEGER ierror
      END SUBROUTINE MPI_PACK_EXTERNAL_SIZE

      SUBROUTINE MPI_OPEN_PORT(info,port_name,ierror)
           INTEGER info
           CHARACTER (LEN=*) port_name
           INTEGER ierror
      END SUBROUTINE MPI_OPEN_PORT

      SUBROUTINE MPI_COMM_SPLIT_TYPE(comm,split_type,key,info,newcomm,ierror)
           INTEGER comm
           INTEGER split_type
           INTEGER key
           INTEGER info
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SPLIT_TYPE

      SUBROUTINE MPI_FILE_CREATE_ERRHANDLER(file_errhandler_fn,errhandler,&
                  ierror)
           INTERFACE
       SUBROUTINE file_errhandler_fn(vv0,vv1)
       INTEGER vv0,vv1
       END SUBROUTINE
       END INTERFACE
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_FILE_CREATE_ERRHANDLER

      SUBROUTINE MPI_COMM_CREATE_GROUP(comm,group,tag,newcomm,ierror)
           INTEGER comm
           INTEGER group
           INTEGER tag
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_CREATE_GROUP

      SUBROUTINE MPI_ATTR_DELETE(comm,keyval,ierror)
           INTEGER comm
           INTEGER keyval
           INTEGER ierror
      END SUBROUTINE MPI_ATTR_DELETE

      SUBROUTINE MPI_WIN_LOCK_ALL(assert,win,ierror)
           INTEGER assert
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_LOCK_ALL

      SUBROUTINE MPI_IBARRIER(comm,request,ierror)
           INTEGER comm
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_IBARRIER

      SUBROUTINE MPI_TYPE_GET_CONTENTS(datatype,max_integers,max_addresses,&
                  max_datatypes,array_of_integers,array_of_addresses,&
                  array_of_datatypes,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER datatype
           INTEGER max_integers
           INTEGER max_addresses
           INTEGER max_datatypes
           INTEGER array_of_integers(*)
           INTEGER(KIND=MPI_ADDRESS_KIND) array_of_addresses(*)
           INTEGER array_of_datatypes(*)
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_CONTENTS

      SUBROUTINE MPI_WIN_FLUSH_ALL(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FLUSH_ALL

      SUBROUTINE MPI_START(request,ierror)
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_START

      SUBROUTINE MPI_FINALIZE(ierror)
           INTEGER ierror
      END SUBROUTINE MPI_FINALIZE

      SUBROUTINE MPI_DIST_GRAPH_NEIGHBORS_COUNT(comm,indegree,outdegree,&
                  weighted,ierror)
           INTEGER comm
           INTEGER indegree
           INTEGER outdegree
           LOGICAL weighted
           INTEGER ierror
      END SUBROUTINE MPI_DIST_GRAPH_NEIGHBORS_COUNT

      SUBROUTINE MPI_COMM_GET_PARENT(parent,ierror)
           INTEGER parent
           INTEGER ierror
      END SUBROUTINE MPI_COMM_GET_PARENT

      SUBROUTINE MPI_FINALIZED(flag,ierror)
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_FINALIZED

      SUBROUTINE MPI_INTERCOMM_MERGE(intercomm,high,newintracomm,ierror)
           INTEGER intercomm
           LOGICAL high
           INTEGER newintracomm
           INTEGER ierror
      END SUBROUTINE MPI_INTERCOMM_MERGE

      SUBROUTINE MPI_INFO_GET_NTHKEY(info,n,key,ierror)
           INTEGER info
           INTEGER n
           CHARACTER (LEN=*) key
           INTEGER ierror
      END SUBROUTINE MPI_INFO_GET_NTHKEY

      SUBROUTINE MPI_TYPE_MATCH_SIZE(typeclass,size,datatype,ierror)
           INTEGER typeclass
           INTEGER size
           INTEGER datatype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_MATCH_SIZE

      SUBROUTINE MPI_INITIALIZED(flag,ierror)
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_INITIALIZED

      SUBROUTINE MPI_TYPE_CONTIGUOUS(count,oldtype,newtype,ierror)
           INTEGER count
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CONTIGUOUS

      SUBROUTINE MPI_TYPE_UB(datatype,displacement,ierror)
           INTEGER datatype
           INTEGER displacement
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_UB

      SUBROUTINE MPI_INFO_DUP(info,newinfo,ierror)
           INTEGER info
           INTEGER newinfo
           INTEGER ierror
      END SUBROUTINE MPI_INFO_DUP

      SUBROUTINE MPI_WIN_DELETE_ATTR(win,win_keyval,ierror)
           INTEGER win
           INTEGER win_keyval
           INTEGER ierror
      END SUBROUTINE MPI_WIN_DELETE_ATTR

      SUBROUTINE MPI_INFO_GET_NKEYS(info,nkeys,ierror)
           INTEGER info
           INTEGER nkeys
           INTEGER ierror
      END SUBROUTINE MPI_INFO_GET_NKEYS

      SUBROUTINE MPI_WIN_CREATE_DYNAMIC(info,comm,win,ierror)
           INTEGER info
           INTEGER comm
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_CREATE_DYNAMIC

      SUBROUTINE MPI_GROUP_EXCL(group,n,ranks,newgroup,ierror)
           INTEGER group
           INTEGER n
           INTEGER ranks(*)
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_EXCL

      SUBROUTINE MPI_WIN_GET_INFO(win,info_used,ierror)
           INTEGER win
           INTEGER info_used
           INTEGER ierror
      END SUBROUTINE MPI_WIN_GET_INFO

      SUBROUTINE MPI_COMM_DELETE_ATTR(comm,comm_keyval,ierror)
           INTEGER comm
           INTEGER comm_keyval
           INTEGER ierror
      END SUBROUTINE MPI_COMM_DELETE_ATTR

      SUBROUTINE MPI_GET_COUNT(status,datatype,count,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER datatype
           INTEGER count
           INTEGER ierror
      END SUBROUTINE MPI_GET_COUNT

      SUBROUTINE MPI_ADD_ERROR_CLASS(errorclass,ierror)
           INTEGER errorclass
           INTEGER ierror
      END SUBROUTINE MPI_ADD_ERROR_CLASS

      SUBROUTINE MPI_COMM_SET_NAME(comm,comm_name,ierror)
           INTEGER comm
           CHARACTER (LEN=*) comm_name
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SET_NAME

      SUBROUTINE MPI_COMM_DISCONNECT(comm,ierror)
           INTEGER comm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_DISCONNECT

      SUBROUTINE MPI_ADD_ERROR_CODE(errorclass,errorcode,ierror)
           INTEGER errorclass
           INTEGER errorcode
           INTEGER ierror
      END SUBROUTINE MPI_ADD_ERROR_CODE

      SUBROUTINE MPI_COMM_GET_ERRHANDLER(comm,errhandler,ierror)
           INTEGER comm
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_COMM_GET_ERRHANDLER

      SUBROUTINE MPI_COMM_CREATE(comm,group,newcomm,ierror)
           INTEGER comm
           INTEGER group
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_CREATE

      SUBROUTINE MPI_COMM_REMOTE_SIZE(comm,size,ierror)
           INTEGER comm
           INTEGER size
           INTEGER ierror
      END SUBROUTINE MPI_COMM_REMOTE_SIZE

      SUBROUTINE MPI_PROBE(source,tag,comm,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER source
           INTEGER tag
           INTEGER comm
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_PROBE

      SUBROUTINE MPI_WIN_WAIT(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_WAIT

      SUBROUTINE MPI_TYPE_CREATE_SUBARRAY(ndims,array_of_sizes,&
                  array_of_subsizes,array_of_starts,order,oldtype,newtype,&
                  ierror)
           INTEGER ndims
           INTEGER array_of_sizes(*)
           INTEGER array_of_subsizes(*)
           INTEGER array_of_starts(*)
           INTEGER order
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_SUBARRAY

      SUBROUTINE MPI_TYPE_SIZE_X(datatype,size,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_COUNT_KIND
           INTEGER datatype
           INTEGER(KIND=MPI_COUNT_KIND) size
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_SIZE_X

      SUBROUTINE MPI_TYPE_FREE(datatype,ierror)
           INTEGER datatype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_FREE

      SUBROUTINE MPI_GRAPHDIMS_GET(comm,nnodes,nedges,ierror)
           INTEGER comm
           INTEGER nnodes
           INTEGER nedges
           INTEGER ierror
      END SUBROUTINE MPI_GRAPHDIMS_GET

      SUBROUTINE MPI_FILE_CALL_ERRHANDLER(fh,errorcode,ierror)
           INTEGER fh
           INTEGER errorcode
           INTEGER ierror
      END SUBROUTINE MPI_FILE_CALL_ERRHANDLER

      SUBROUTINE MPI_TYPE_DELETE_ATTR(datatype,type_keyval,ierror)
           INTEGER datatype
           INTEGER type_keyval
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_DELETE_ATTR

      SUBROUTINE MPI_TYPE_CREATE_HINDEXED(count,array_of_blocklengths,&
                  array_of_displacements,oldtype,newtype,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER count
           INTEGER array_of_blocklengths(*)
           INTEGER(KIND=MPI_ADDRESS_KIND) array_of_displacements(*)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_HINDEXED

      SUBROUTINE MPI_STATUS_SET_ELEMENTS_X(status,datatype,count,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_COUNT_KIND, MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER datatype
           INTEGER(KIND=MPI_COUNT_KIND) count
           INTEGER ierror
      END SUBROUTINE MPI_STATUS_SET_ELEMENTS_X

      SUBROUTINE MPI_TYPE_INDEXED(count,array_of_blocklengths,&
                  array_of_displacements,oldtype,newtype,ierror)
           INTEGER count
           INTEGER array_of_blocklengths(*)
           INTEGER array_of_displacements(*)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_INDEXED

      SUBROUTINE MPI_GRAPH_NEIGHBORS_COUNT(comm,rank,nneighbors,ierror)
           INTEGER comm
           INTEGER rank
           INTEGER nneighbors
           INTEGER ierror
      END SUBROUTINE MPI_GRAPH_NEIGHBORS_COUNT

      SUBROUTINE MPI_KEYVAL_FREE(keyval,ierror)
           INTEGER keyval
           INTEGER ierror
      END SUBROUTINE MPI_KEYVAL_FREE

      SUBROUTINE MPI_GROUP_DIFFERENCE(group1,group2,newgroup,ierror)
           INTEGER group1
           INTEGER group2
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_DIFFERENCE

      SUBROUTINE MPI_COMM_DUP(comm,newcomm,ierror)
           INTEGER comm
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_DUP

      SUBROUTINE MPI_ERROR_CLASS(errorcode,errorclass,ierror)
           INTEGER errorcode
           INTEGER errorclass
           INTEGER ierror
      END SUBROUTINE MPI_ERROR_CLASS

      SUBROUTINE MPI_COMM_FREE_KEYVAL(comm_keyval,ierror)
           INTEGER comm_keyval
           INTEGER ierror
      END SUBROUTINE MPI_COMM_FREE_KEYVAL

      SUBROUTINE MPI_GET_LIBRARY_VERSION(version,resultlen,ierror)
           CHARACTER (LEN=*) version
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_GET_LIBRARY_VERSION

      SUBROUTINE MPI_WIN_FLUSH_LOCAL(rank,win,ierror)
           INTEGER rank
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FLUSH_LOCAL

      SUBROUTINE MPI_GROUP_INTERSECTION(group1,group2,newgroup,ierror)
           INTEGER group1
           INTEGER group2
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_INTERSECTION

      SUBROUTINE MPI_CARTDIM_GET(comm,ndims,ierror)
           INTEGER comm
           INTEGER ndims
           INTEGER ierror
      END SUBROUTINE MPI_CARTDIM_GET

      SUBROUTINE MPI_WIN_GET_ERRHANDLER(win,errhandler,ierror)
           INTEGER win
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_WIN_GET_ERRHANDLER

      SUBROUTINE MPI_CANCEL(request,ierror)
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_CANCEL

      SUBROUTINE MPI_WIN_POST(group,assert,win,ierror)
           INTEGER group
           INTEGER assert
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_POST

      SUBROUTINE MPI_TEST_CANCELLED(status,flag,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_TEST_CANCELLED

      SUBROUTINE MPI_ADD_ERROR_STRING(errorcode,string,ierror)
           INTEGER errorcode
           CHARACTER (LEN=*) string
           INTEGER ierror
      END SUBROUTINE MPI_ADD_ERROR_STRING

      SUBROUTINE MPI_GET_ELEMENTS(status,datatype,count,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER datatype
           INTEGER count
           INTEGER ierror
      END SUBROUTINE MPI_GET_ELEMENTS

      SUBROUTINE MPI_PACK_SIZE(incount,datatype,comm,size,ierror)
           INTEGER incount
           INTEGER datatype
           INTEGER comm
           INTEGER size
           INTEGER ierror
      END SUBROUTINE MPI_PACK_SIZE

      SUBROUTINE MPI_ERRHANDLER_GET(comm,errhandler,ierror)
           INTEGER comm
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_ERRHANDLER_GET

      SUBROUTINE MPI_WIN_SET_INFO(win,info,ierror)
           INTEGER win
           INTEGER info
           INTEGER ierror
      END SUBROUTINE MPI_WIN_SET_INFO

      SUBROUTINE MPI_OP_COMMUTATIVE(op,commute,ierror)
           INTEGER op
           LOGICAL commute
           INTEGER ierror
      END SUBROUTINE MPI_OP_COMMUTATIVE

      SUBROUTINE MPI_TYPE_LB(datatype,displacement,ierror)
           INTEGER datatype
           INTEGER displacement
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_LB

      SUBROUTINE MPI_GROUP_RANGE_INCL(group,n,ranges,newgroup,ierror)
           INTEGER group
           INTEGER n
           INTEGER ranges(3,*)
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_RANGE_INCL

      SUBROUTINE MPI_TYPE_GET_TRUE_EXTENT(datatype,true_lb,true_extent,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER datatype
           INTEGER(KIND=MPI_ADDRESS_KIND) true_lb
           INTEGER(KIND=MPI_ADDRESS_KIND) true_extent
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_TRUE_EXTENT

      SUBROUTINE MPI_IS_THREAD_MAIN(flag,ierror)
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_IS_THREAD_MAIN

      SUBROUTINE MPI_WIN_FREE_KEYVAL(win_keyval,ierror)
           INTEGER win_keyval
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FREE_KEYVAL

      SUBROUTINE MPI_QUERY_THREAD(provided,ierror)
           INTEGER provided
           INTEGER ierror
      END SUBROUTINE MPI_QUERY_THREAD

      SUBROUTINE MPI_ERRHANDLER_CREATE(function,errhandler,ierror)
           INTERFACE
       SUBROUTINE function(vv0,vv1)
       INTEGER vv0,vv1
       END SUBROUTINE
       END INTERFACE
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_ERRHANDLER_CREATE

      SUBROUTINE MPI_TYPE_GET_TRUE_EXTENT_X(datatype,lb,extent,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_COUNT_KIND
           INTEGER datatype
           INTEGER(KIND=MPI_COUNT_KIND) lb
           INTEGER(KIND=MPI_COUNT_KIND) extent
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_TRUE_EXTENT_X

      SUBROUTINE MPI_IMPROBE(source,tag,comm,flag,message,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER source
           INTEGER tag
           INTEGER comm
           LOGICAL flag
           INTEGER message
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_IMPROBE

      SUBROUTINE MPI_COMM_REMOTE_GROUP(comm,group,ierror)
           INTEGER comm
           INTEGER group
           INTEGER ierror
      END SUBROUTINE MPI_COMM_REMOTE_GROUP

      SUBROUTINE MPI_COMM_COMPARE(comm1,comm2,result,ierror)
           INTEGER comm1
           INTEGER comm2
           INTEGER result
           INTEGER ierror
      END SUBROUTINE MPI_COMM_COMPARE

      SUBROUTINE MPI_INFO_GET(info,key,valuelen,value,flag,ierror)
           INTEGER info
           CHARACTER (LEN=*) key
           INTEGER valuelen
           CHARACTER (LEN=*) value
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_INFO_GET

      SUBROUTINE MPI_TYPE_VECTOR(count,blocklength,stride,oldtype,newtype,&
                  ierror)
           INTEGER count
           INTEGER blocklength
           INTEGER stride
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_VECTOR

      SUBROUTINE MPI_COMM_DUP_WITH_INFO(comm,info,newcomm,ierror)
           INTEGER comm
           INTEGER info
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_DUP_WITH_INFO

      SUBROUTINE MPI_WIN_SET_ERRHANDLER(win,errhandler,ierror)
           INTEGER win
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_WIN_SET_ERRHANDLER

      SUBROUTINE MPI_COMM_SPAWN(command,argv,maxprocs,info,root,comm,intercomm,&
                  array_of_errcodes,ierror)
           CHARACTER (LEN=*) command
           CHARACTER (LEN=*) argv(*)
           INTEGER maxprocs
           INTEGER info
           INTEGER root
           INTEGER comm
           INTEGER intercomm
           INTEGER array_of_errcodes(*)
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SPAWN

      SUBROUTINE MPI_GROUP_FREE(group,ierror)
           INTEGER group
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_FREE

      SUBROUTINE MPI_COMM_SET_ERRHANDLER(comm,errhandler,ierror)
           INTEGER comm
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SET_ERRHANDLER

      SUBROUTINE MPI_WIN_TEST(win,flag,ierror)
           INTEGER win
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_WIN_TEST

      SUBROUTINE MPI_WIN_FLUSH_LOCAL_ALL(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FLUSH_LOCAL_ALL

      SUBROUTINE MPI_GRAPH_MAP(comm,nnodes,indx,edges,newrank,ierror)
           INTEGER comm
           INTEGER nnodes
           INTEGER indx(*)
           INTEGER edges(*)
           INTEGER newrank
           INTEGER ierror
      END SUBROUTINE MPI_GRAPH_MAP

      SUBROUTINE MPI_PUBLISH_NAME(service_name,info,port_name,ierror)
           CHARACTER (LEN=*) service_name
           INTEGER info
           CHARACTER (LEN=*) port_name
           INTEGER ierror
      END SUBROUTINE MPI_PUBLISH_NAME

      SUBROUTINE MPI_TYPE_GET_EXTENT_X(datatype,lb,extent,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_COUNT_KIND
           INTEGER datatype
           INTEGER(KIND=MPI_COUNT_KIND) lb
           INTEGER(KIND=MPI_COUNT_KIND) extent
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_EXTENT_X

      SUBROUTINE MPI_TYPE_CREATE_F90_REAL(precision,range,newtype,ierror)
           INTEGER precision
           INTEGER range
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_F90_REAL

      SUBROUTINE MPI_GROUP_UNION(group1,group2,newgroup,ierror)
           INTEGER group1
           INTEGER group2
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_UNION

      SUBROUTINE MPI_COMM_ACCEPT(port_name,info,root,comm,newcomm,ierror)
           CHARACTER (LEN=*) port_name
           INTEGER info
           INTEGER root
           INTEGER comm
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_ACCEPT

      SUBROUTINE MPI_WIN_GET_NAME(win,win_name,resultlen,ierror)
           INTEGER win
           CHARACTER (LEN=*) win_name
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_WIN_GET_NAME

      SUBROUTINE MPI_INFO_CREATE(info,ierror)
           INTEGER info
           INTEGER ierror
      END SUBROUTINE MPI_INFO_CREATE

      SUBROUTINE MPI_TYPE_CREATE_F90_INTEGER(range,newtype,ierror)
           INTEGER range
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_F90_INTEGER

      SUBROUTINE MPI_TYPE_SET_NAME(datatype,type_name,ierror)
           INTEGER datatype
           CHARACTER (LEN=*) type_name
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_SET_NAME

      SUBROUTINE MPI_GROUP_INCL(group,n,ranks,newgroup,ierror)
           INTEGER group
           INTEGER n
           INTEGER ranks(*)
           INTEGER newgroup
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_INCL

      SUBROUTINE MPI_COMM_CONNECT(port_name,info,root,comm,newcomm,ierror)
           CHARACTER (LEN=*) port_name
           INTEGER info
           INTEGER root
           INTEGER comm
           INTEGER newcomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_CONNECT

      SUBROUTINE MPI_COMM_CREATE_ERRHANDLER(comm_errhandler_fn,errhandler,&
                  ierror)
           INTERFACE
       SUBROUTINE comm_errhandler_fn(vv0,vv1)
       INTEGER vv0,vv1
       END SUBROUTINE
       END INTERFACE
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_COMM_CREATE_ERRHANDLER

      SUBROUTINE MPI_ERROR_STRING(errorcode,string,resultlen,ierror)
           INTEGER errorcode
           CHARACTER (LEN=*) string
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_ERROR_STRING

      SUBROUTINE MPI_TYPE_STRUCT(count,array_of_blocklengths,&
                  array_of_displacements,array_of_types,newtype,ierror)
           INTEGER count
           INTEGER array_of_blocklengths(*)
           INTEGER array_of_displacements(*)
           INTEGER array_of_types(*)
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_STRUCT

      SUBROUTINE MPI_TYPE_CREATE_INDEXED_BLOCK(count,blocklength,&
                  array_of_displacements,oldtype,newtype,ierror)
           INTEGER count
           INTEGER blocklength
           INTEGER array_of_displacements(*)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_INDEXED_BLOCK

      SUBROUTINE MPI_TYPE_CREATE_HVECTOR(count,blocklength,stride,oldtype,&
                  newtype,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER count
           INTEGER blocklength
           INTEGER(KIND=MPI_ADDRESS_KIND) stride
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_HVECTOR

      SUBROUTINE MPI_ABORT(comm,errorcode,ierror)
           INTEGER comm
           INTEGER errorcode
           INTEGER ierror
      END SUBROUTINE MPI_ABORT

      SUBROUTINE MPI_TYPE_FREE_KEYVAL(type_keyval,ierror)
           INTEGER type_keyval
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_FREE_KEYVAL

      SUBROUTINE MPI_INTERCOMM_CREATE(local_comm,local_leader,peer_comm,&
                  remote_leader,tag,newintercomm,ierror)
           INTEGER local_comm
           INTEGER local_leader
           INTEGER peer_comm
           INTEGER remote_leader
           INTEGER tag
           INTEGER newintercomm
           INTEGER ierror
      END SUBROUTINE MPI_INTERCOMM_CREATE

      SUBROUTINE MPI_COMM_RANK(comm,rank,ierror)
           INTEGER comm
           INTEGER rank
           INTEGER ierror
      END SUBROUTINE MPI_COMM_RANK

      SUBROUTINE MPI_COMM_IDUP(comm,newcomm,request,ierror)
           INTEGER comm
           INTEGER newcomm
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_COMM_IDUP

      SUBROUTINE MPI_STATUS_SET_CANCELLED(status,flag,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_STATUS_SET_CANCELLED

      SUBROUTINE MPI_FILE_SET_ERRHANDLER(file,errhandler,ierror)
           INTEGER file
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_FILE_SET_ERRHANDLER

      SUBROUTINE MPI_UNPUBLISH_NAME(service_name,info,port_name,ierror)
           CHARACTER (LEN=*) service_name
           INTEGER info
           CHARACTER (LEN=*) port_name
           INTEGER ierror
      END SUBROUTINE MPI_UNPUBLISH_NAME

      SUBROUTINE MPI_INFO_DELETE(info,key,ierror)
           INTEGER info
           CHARACTER (LEN=*) key
           INTEGER ierror
      END SUBROUTINE MPI_INFO_DELETE

      SUBROUTINE MPI_TYPE_CREATE_RESIZED(oldtype,lb,extent,newtype,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_ADDRESS_KIND
           INTEGER oldtype
           INTEGER(KIND=MPI_ADDRESS_KIND) lb
           INTEGER(KIND=MPI_ADDRESS_KIND) extent
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_RESIZED

      SUBROUTINE MPI_ERRHANDLER_SET(comm,errhandler,ierror)
           INTEGER comm
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_ERRHANDLER_SET

      SUBROUTINE MPI_TYPE_DUP(oldtype,newtype,ierror)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_DUP

      SUBROUTINE MPI_WIN_FLUSH(rank,win,ierror)
           INTEGER rank
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FLUSH

      SUBROUTINE MPI_WAIT(request,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER request
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_WAIT

      SUBROUTINE MPI_INFO_SET(info,key,value,ierror)
           INTEGER info
           CHARACTER (LEN=*) key
           CHARACTER (LEN=*) value
           INTEGER ierror
      END SUBROUTINE MPI_INFO_SET

      SUBROUTINE MPI_TEST(request,flag,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER request
           LOGICAL flag
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_TEST

      SUBROUTINE MPI_COMM_GET_NAME(comm,comm_name,resultlen,ierror)
           INTEGER comm
           CHARACTER (LEN=*) comm_name
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_COMM_GET_NAME

      SUBROUTINE MPI_COMM_FREE(comm,ierror)
           INTEGER comm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_FREE

      SUBROUTINE MPI_COMM_GET_INFO(comm,info,ierror)
           INTEGER comm
           INTEGER info
           INTEGER ierror
      END SUBROUTINE MPI_COMM_GET_INFO

      SUBROUTINE MPI_IPROBE(source,tag,comm,flag,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER source
           INTEGER tag
           INTEGER comm
           LOGICAL flag
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_IPROBE

      SUBROUTINE MPI_GET_PROCESSOR_NAME(name,resultlen,ierror)
           CHARACTER (LEN=*) name
           INTEGER resultlen
           INTEGER ierror
      END SUBROUTINE MPI_GET_PROCESSOR_NAME

      SUBROUTINE MPI_TOPO_TEST(comm,status,ierror)
           INTEGER comm
           INTEGER status
           INTEGER ierror
      END SUBROUTINE MPI_TOPO_TEST

      SUBROUTINE MPI_OP_FREE(op,ierror)
           INTEGER op
           INTEGER ierror
      END SUBROUTINE MPI_OP_FREE

      SUBROUTINE MPI_COMM_SIZE(comm,size,ierror)
           INTEGER comm
           INTEGER size
           INTEGER ierror
      END SUBROUTINE MPI_COMM_SIZE

      SUBROUTINE MPI_WIN_UNLOCK(rank,win,ierror)
           INTEGER rank
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_UNLOCK

      SUBROUTINE MPI_ERRHANDLER_FREE(errhandler,ierror)
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_ERRHANDLER_FREE

      SUBROUTINE MPI_WIN_UNLOCK_ALL(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_UNLOCK_ALL

      SUBROUTINE MPI_TYPE_HINDEXED(count,array_of_blocklengths,&
                  array_of_displacements,oldtype,newtype,ierror)
           INTEGER count
           INTEGER array_of_blocklengths(*)
           INTEGER array_of_displacements(*)
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_HINDEXED

      SUBROUTINE MPI_MPROBE(source,tag,comm,message,status,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_STATUS_SIZE
           INTEGER source
           INTEGER tag
           INTEGER comm
           INTEGER message
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER ierror
      END SUBROUTINE MPI_MPROBE

      SUBROUTINE MPI_WIN_SET_NAME(win,win_name,ierror)
           INTEGER win
           CHARACTER (LEN=*) win_name
           INTEGER ierror
      END SUBROUTINE MPI_WIN_SET_NAME

      SUBROUTINE MPI_TYPE_SIZE(datatype,size,ierror)
           INTEGER datatype
           INTEGER size
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_SIZE

      SUBROUTINE MPI_WIN_START(group,assert,win,ierror)
           INTEGER group
           INTEGER assert
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_START

      SUBROUTINE MPI_WIN_CREATE_ERRHANDLER(win_errhandler_fn,errhandler,ierror)
           INTERFACE
       SUBROUTINE win_errhandler_fn(vv0,vv1)
       INTEGER vv0,vv1
       END SUBROUTINE
       END INTERFACE
           INTEGER errhandler
           INTEGER ierror
      END SUBROUTINE MPI_WIN_CREATE_ERRHANDLER

      SUBROUTINE MPI_WIN_FENCE(assert,win,ierror)
           INTEGER assert
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_FENCE

      SUBROUTINE MPI_TYPE_GET_ENVELOPE(datatype,num_integers,num_addresses,&
                  num_datatypes,combiner,ierror)
           INTEGER datatype
           INTEGER num_integers
           INTEGER num_addresses
           INTEGER num_datatypes
           INTEGER combiner
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_GET_ENVELOPE

      SUBROUTINE MPI_GREQUEST_COMPLETE(request,ierror)
           INTEGER request
           INTEGER ierror
      END SUBROUTINE MPI_GREQUEST_COMPLETE

      SUBROUTINE MPI_GET_VERSION(version,subversion,ierror)
           INTEGER version
           INTEGER subversion
           INTEGER ierror
      END SUBROUTINE MPI_GET_VERSION

      SUBROUTINE MPI_TYPE_HVECTOR(count,blocklength,stride,oldtype,newtype,&
                  ierror)
           INTEGER count
           INTEGER blocklength
           INTEGER stride
           INTEGER oldtype
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_HVECTOR

      SUBROUTINE MPI_WIN_SYNC(win,ierror)
           INTEGER win
           INTEGER ierror
      END SUBROUTINE MPI_WIN_SYNC

      SUBROUTINE MPI_GET_ELEMENTS_X(status,datatype,count,ierror)
           USE MPI_CONSTANTS,ONLY:MPI_COUNT_KIND, MPI_STATUS_SIZE
           INTEGER status(MPI_STATUS_SIZE)
           INTEGER datatype
           INTEGER(KIND=MPI_COUNT_KIND) count
           INTEGER ierror
      END SUBROUTINE MPI_GET_ELEMENTS_X

      SUBROUTINE MPI_COMM_CALL_ERRHANDLER(comm,errorcode,ierror)
           INTEGER comm
           INTEGER errorcode
           INTEGER ierror
      END SUBROUTINE MPI_COMM_CALL_ERRHANDLER

      SUBROUTINE MPI_COMM_TEST_INTER(comm,flag,ierror)
           INTEGER comm
           LOGICAL flag
           INTEGER ierror
      END SUBROUTINE MPI_COMM_TEST_INTER

      SUBROUTINE MPI_COMM_JOIN(fd,intercomm,ierror)
           INTEGER fd
           INTEGER intercomm
           INTEGER ierror
      END SUBROUTINE MPI_COMM_JOIN

      SUBROUTINE MPI_CLOSE_PORT(port_name,ierror)
           CHARACTER (LEN=*) port_name
           INTEGER ierror
      END SUBROUTINE MPI_CLOSE_PORT

      SUBROUTINE MPI_TYPE_CREATE_F90_COMPLEX(precision,range,newtype,ierror)
           INTEGER precision
           INTEGER range
           INTEGER newtype
           INTEGER ierror
      END SUBROUTINE MPI_TYPE_CREATE_F90_COMPLEX

      SUBROUTINE MPI_GROUP_RANK(group,rank,ierror)
           INTEGER group
           INTEGER rank
           INTEGER ierror
      END SUBROUTINE MPI_GROUP_RANK

        SUBROUTINE MPI_INIT(ierror)
        INTEGER ierror
        END SUBROUTINE MPI_INIT

        SUBROUTINE MPI_INIT_THREAD(v0,v1,ierror)
        INTEGER v0, v1, ierror
        END SUBROUTINE MPI_INIT_THREAD

        FUNCTION MPI_WTIME()
             MPI_WTIME
        END FUNCTION MPI_WTIME
!
        FUNCTION MPI_WTICK()
             MPI_WTICK
        END FUNCTION MPI_WTICK

! style:PMPIuse:PMPI_WTIME:3 sig:0
        FUNCTION PMPI_WTIME()
             PMPI_WTIME
        END FUNCTION PMPI_WTIME
!
! style:PMPIuse:PMPI_WTICK:3 sig:0
        FUNCTION PMPI_WTICK()
             PMPI_WTICK
        END FUNCTION PMPI_WTICK

        SUBROUTINE MPI_NULL_DELETE_FN(COMM, KEYVAL, ATTRIBUTE_VAL,&
          EXTRA_STATE, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER COMM, KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) ATTRIBUTE_VAL, EXTRA_STATE
        END SUBROUTINE MPI_NULL_DELETE_FN

        SUBROUTINE MPI_DUP_FN(OLDCOMM, KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDCOMM, KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_DUP_FN

        SUBROUTINE MPI_NULL_COPY_FN(OLDCOMM, KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDCOMM, KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_NULL_COPY_FN

        SUBROUTINE MPI_COMM_NULL_DELETE_FN(COMM, COMM_KEYVAL, ATTRIBUTE_VAL,&
          EXTRA_STATE, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER COMM, COMM_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) ATTRIBUTE_VAL, EXTRA_STATE
        END SUBROUTINE MPI_COMM_NULL_DELETE_FN

        SUBROUTINE MPI_COMM_DUP_FN(OLDCOMM, COMM_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDCOMM, COMM_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_COMM_DUP_FN

        SUBROUTINE MPI_COMM_NULL_COPY_FN(OLDCOMM, COMM_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDCOMM, COMM_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_COMM_NULL_COPY_FN

        SUBROUTINE MPI_TYPE_NULL_DELETE_FN(DATATYPE, TYPE_KEYVAL, ATTRIBUTE_VAL,&
          EXTRA_STATE, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER DATATYPE, TYPE_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) ATTRIBUTE_VAL, EXTRA_STATE
        END SUBROUTINE MPI_TYPE_NULL_DELETE_FN

        SUBROUTINE MPI_TYPE_DUP_FN(OLDTYPE, TYPE_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDTYPE, TYPE_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_TYPE_DUP_FN

        SUBROUTINE MPI_TYPE_NULL_COPY_FN(OLDTYPE, TYPE_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDTYPE, TYPE_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_TYPE_NULL_COPY_FN

        SUBROUTINE MPI_WIN_NULL_DELETE_FN(WIN, WIN_KEYVAL, ATTRIBUTE_VAL,&
          EXTRA_STATE, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER WIN, WIN_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) ATTRIBUTE_VAL, EXTRA_STATE
        END SUBROUTINE MPI_WIN_NULL_DELETE_FN

        SUBROUTINE MPI_WIN_DUP_FN(OLDWIN, WIN_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDWIN, WIN_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_WIN_DUP_FN

        SUBROUTINE MPI_WIN_NULL_COPY_FN(OLDWIN, WIN_KEYVAL, EXTRA_STATE,&
          ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT, FLAG, IERROR)
            USE MPI_CONSTANTS,ONLY: MPI_ADDRESS_KIND
            INTEGER OLDWIN, WIN_KEYVAL, IERROR
            INTEGER(KIND=MPI_ADDRESS_KIND) EXTRA_STATE, ATTRIBUTE_VAL_IN, ATTRIBUTE_VAL_OUT
            LOGICAL FLAG
        END SUBROUTINE MPI_WIN_NULL_COPY_FN
       END INTERFACE
       END MODULE MPI_BASE

max_stars_repo_name: valiantljk/collectiveIO-profile

max_issues_repo_name: valiantljk/collectiveIO-profile

max_forks_repo_name: valiantljk/collectiveIO-profile


text:
!***********************************************************************
      subroutine sys_getwd (dir, dir_len)
      implicit none
      character(len=*), intent(out):: dir
      integer, intent(out):: dir_len
      character(len=*), parameter::iam = 'SUN'  ! soly for machine
c      character(len=len_trim (iam)), optional, intent(out):: machine

!   This routine gets current working directory and assigns it to dir.
!   ierr will be zero if successful, otherwise non-zero;
!   machine is an optional parameter specifying the name of the system
!
!   Xinghong He  98-08-24
!
!***********************************************************************

      dir = ''
      call GETCWD(dir)
      dir_len = len_trim(dir)

      return
      end


text:
      subroutine DHERQL(AR, AI, LDA, N, EVAL, VR, VI, WORK, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 DHERQL Krogh  Changes to use M77CON
C>> 1994-04-20 DHERQL CLL Edited comment to make DP & SP files similar.
c>> 1992-04-23 CLL  Declaring all variables.
c>> 1992-04-08 DHERQL  Removed unused label 220.
c>> 1991-10-23 DHERQL  Krogh Initial version, converted from EISPACK.
c
c     This subroutine reduces a complex hermitian matrix to a real
c     symmetric tridiagonal matrix using unitary similarity
c     transformations, computes the eigenvalues and eigenvectors of the
c     tridiagonal matrix, and then computes the eigenvectors of the
c     original matrix.
c
c     This subroutine is a concatenation of a slight modification of the
c     EISPACK subroutine HTRIDI, a call to DIMQL which is a slight
c     modification of the EISPACK subroutine IMTQL2, and a slight
c     modification of the EISPACK subroutine HTRIBK.  These subroutines
c     in turn are a translation of a complex analogue of the ALGOL
c     procedure TRED1, Num. Math. 11, 181-195(1968) by Martin, Reinsch,
c     and Wilkinson. Handbook for Auto. Comp., Vol.ii-Linear Algebra,
c     212-226(1971), and the complex analogue of the ALGOL procedure
c     TRBAK1, Num. Math. 11, 181-195(1968) by Martin, Reinsch, and
c     Wilkinson.  Handbook for Auto. Comp., vol.ii-Linear Algebra,
c     212-226(1971).
c     EISPACK routines are dated August 1983.
c
c     On input
c
c        AR and AI contain the real and imaginary parts,
c          respectively, of the complex hermitian input matrix.
c          only the lower triangle of the matrix need be supplied.
c
c        LDA must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        N is the order of the matrix.
c
c     On output
c
c     AR and AI contain information about the unitary transformations
c          used in the reduction in their full lower triangles.  Their
c          strict upper triangles and the diagonal of AR are unaltered.
c
c     EVAL contains the eigenvalues in ascending order.  If an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,IERR-1, and no eigenvectors are
c          computed.
c
c     VR and VI contain the the real and imaginary parts of the
c     eigenvectors with column k corresponding to the eigenvalue in
c     EVAL(k).  Note that the last component of each returned vector
c     is real and that vector euclidean norms are preserved.
c
c     WORK used for working storage.
c
c     IERR is set to:
c          zero  for normal return,
c          J     if the J-th eigenvalue has not been determined after 30
c                iterations.
c
c     ------------------------------------------------------------------
c--D replaces "?": ?HERQL, ?IMQL
c     Both versions use IERM1
c     ------------------------------------------------------------------
      integer I, IERR, J,K,L,N,LDA,N1,N2
      double precision AR(LDA,N),AI(LDA,N),EVAL(N),WORK(*)
      double precision VR(LDA,N),VI(LDA,N)
      double precision F,G,H,FI,GI,HH,SI,SCALE
      double precision S
c     ------------------------------------------------------------------
      N1 = N
      N2 = N1 + N1
      WORK(N2) = 1.0D0
      WORK(N2 + N1) = 0.0D0
c
      do 100 I = 1, N1
         EVAL(I) = AR(I,I)
  100 continue
      if (N1 .le. 1) then
         if (N1 .eq. 1) then
            AR(1,1) = 1.0d0
            AI(1,1) = 0.0d0
         else
            call IERM1('DHERQL',-1, 0, 'Require N > 0.', 'N', N1, '.')
            IERR = -1
         end if
         return
      end if
      do 300 I = N1, 1, -1
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         if (L .lt. 1) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 K = 1, L
            SCALE = SCALE + abs(AR(I,K)) + abs(AI(I,K))
  120    continue
c
         if (SCALE .ne. 0.0D0) go to 140
         WORK(N1 + L) = 1.0D0
         WORK(N2 + L) = 0.0D0
  130    WORK(I) = 0.0D0
         go to 290
c
  140    do 150 K = 1, L
            AR(I,K) = AR(I,K) / SCALE
            AI(I,K) = AI(I,K) / SCALE
            H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
  150    continue
c
         G = sqrt(H)
         WORK(I) = SCALE * G
         F = abs(AR(I,L))
         SI = abs(AI(I,L))
         if (F .gt. SI) then
            F = F * sqrt(1.0d0 + (SI / F) **2)
         else if (SI .ne. 0.0d0) then
            F = SI * sqrt(1.0d0 + (F / SI) **2)
         else
            WORK(N1 + L) = -WORK(N1 + I)
            SI = WORK(N2 + I)
            AR(I,L) = G
            go to 170
         end if
c     .......... Form next diagonal element of matrix t ..........
         WORK(N1+L) = (AI(I,L) * WORK(N2+I) - AR(I,L) * WORK(N1+I)) / F
         SI = (AR(I,L) * WORK(N2 + I) + AI(I,L) * WORK(N1 + I)) / F
         H = H + F * G
         G = 1.0D0 + G / F
         AR(I,L) = G * AR(I,L)
         AI(I,L) = G * AI(I,L)
         if (L .eq. 1) go to 270
         F = 0.0D0
c
  170    do 240 J = 1, L
            G = 0.0D0
            GI = 0.0D0
c     .......... form element of a*u ..........
            do 180 K = 1, J
               G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
               GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
  180       continue
c
            do 200 K = J+1, L
               G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
               GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
  200       continue
c     .......... form element of p ..........
            WORK(J) = G / H
            WORK(N2 + J) = GI / H
            F = F + WORK(J) * AR(I,J) - WORK(N2 + J) * AI(I,J)
  240    continue
c
         HH = F / (H + H)
c     .......... form reduced a ..........
         do 260 J = 1, L
            F = AR(I,J)
            G = WORK(J) - HH * F
            WORK(J) = G
            FI = -AI(I,J)
            GI = WORK(N2 + J) - HH * FI
            WORK(N2 + J) = -GI
c
            do 250 K = 1, J
               AR(J,K) = AR(J,K) - F * WORK(K) - G * AR(I,K)
     x                           + FI * WORK(N2 + K) + GI * AI(I,K)
               AI(J,K) = AI(J,K) - F * WORK(N2 + K) - G * AI(I,K)
     x                           - FI * WORK(K) - GI * AR(I,K)
  250       continue
  260    continue
c
  270    do 280 K = 1, L
            AR(I,K) = SCALE * AR(I,K)
            AI(I,K) = SCALE * AI(I,K)
  280    continue
c
         WORK(N2 + L) = -SI
  290    HH = EVAL(I)
         EVAL(I) = AR(I,I)
         AR(I,I) = HH
         AI(I,I) = SCALE * sqrt(H)
  300 continue
c
c     ------------------------------------------------------------------
c
      do 420 I = 1, N1
         do 410 J = 1, N1
            VR(I,J) = 0.0d0
  410    continue
         VR(I,I) = 1.0d0
  420 continue
      call DIMQL(VR, LDA, N1, EVAL, WORK, IERR)
      if (IERR .ne. 0) return
c
c     ------------------------------------------------------------------
c
c     .......... transform the eigenvectors of the real symmetric
c                tridiagonal matrix to those of the hermitian
c                tridiagonal matrix. ..........
      do 550 K = 1, N1
c
         do 540 J = 1, N1
            VI(K,J) = -VR(K,J) * WORK(N2 + K)
            VR(K,J) = VR(K,J) * WORK(N1 + K)
  540    continue
  550 continue
c
c     .......... Recover and apply the Householder matrices ..........
      do 640 I = 2, N1
         L = I - 1
         H = AI(I,I)
         if (H .ne. 0.0D0) then
            do 630 J = 1, N1
               S = 0.0D0
               SI = 0.0D0
               do 610 K = 1, L
                  S = S + AR(I,K) * VR(K,J) - AI(I,K) * VI(K,J)
                  SI = SI + AR(I,K) * VI(K,J) + AI(I,K) * VR(K,J)
  610          continue
c        .......... double divisions avoid possible underflow ..........
               S = (S / H) / H
               SI = (SI / H) / H
c
               do 620 K = 1, L
                  VR(K,J) = VR(K,J) - S * AR(I,K) - SI * AI(I,K)
                  VI(K,J) = VI(K,J) - SI * AR(I,K) + S * AI(I,K)
  620          continue
  630       continue
         end if
  640 continue
c
      return
      end


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20110311 16:25:12 nbsp Welcome to the Wiki. Have you met Users/SunnyBhardwaj and Users/TonySingh? Users/JasonAller

20110311 17:02:42 nbsp If you have, you might want to explain to SunnyBhardwaj the difference between homey and homely. Users/CovertProfessor


text:
!< Abstract base object, the ancestor of all.
module wenoof_base_object
!< Abstract base object, the ancestor of all.
!<
!< Define a minimal, base, object that is used as ancestor of all objects, e.g. smoothness indicator, optimal weights, etc...

implicit none
private
public :: base_object
public :: base_object_constructor

type :: base_object_constructor
  !< Abstract base object constructor.
endtype base_object_constructor

type, abstract :: base_object
  !< Abstract base object, the ancestor of all.
  !<
  !< Define a minimal, base, object that is used as ancestor of all objects, e.g. smoothness indicator, optimal weights, etc...
  contains
    ! deferred public methods
    procedure(create_interface),      pass(self), deferred :: create      !< Create object.
    procedure(description_interface), nopass,     deferred :: description !< Return object string-description.
    procedure(destroy_interface),     pass(self), deferred :: destroy     !< Destroy object.
endtype base_object

abstract interface
  !< Abstract interface of [base_object] methods.

  subroutine create_interface(self, constructor)
  !< Create object.
  !<
  !< @note Before call this method a concrete constructor must be instantiated.
  import :: base_object
  import :: base_object_constructor
  class(base_object),              intent(inout) :: self        !< Object.
  class(base_object_constructor),  intent(in)    :: constructor !< Object constructor.
  endsubroutine create_interface

  pure function description_interface() result(string)
  !< Return object string-description.
  character(len=:), allocatable  :: string !< String-description.
  endfunction description_interface

  elemental subroutine destroy_interface(self)
  !< Destroy object
  import :: base_object
  class(base_object), intent(inout) :: self !< Object.
  endsubroutine destroy_interface
endinterface
endmodule wenoof_base_object

max_stars_repo_name: giacrossi/WenOOF

max_issues_repo_name: giacrossi/WenOOF

max_forks_repo_name: giacrossi/WenOOF