!
! The file contain Cray PVP (C90, J90, T90 etc) UniCOS system
! specific subroutines
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE DUMMY ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE dummy
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Dummy subroutine to substitute Cray function ASNCTL.
!
!-----------------------------------------------------------------------
!
RETURN
END SUBROUTINE dummy
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE UNIXCMD ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE unixcmd(cmd) 17
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! To executable a system command by making a system call.
!
!-----------------------------------------------------------------------
!
! Author: Ming Xue
! Date: 4/15/95
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
CHARACTER (LEN=*) :: cmd
INTEGER :: ishell,istat
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
istat = ishell( cmd )
RETURN
END SUBROUTINE unixcmd
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE CMPRS ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE cmprs(filename) 4,9
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Make a system call to compress the file 'filename' with
! using gzip or when gzip fails compress.
!
!-----------------------------------------------------------------------
!
! Author: Ming Xue
! Date: 11/30/93
!
! MODIFICATION HISTORY:
!
! 9/1/94 (Y. Lu)
! Cleaned up documentation.
!
! 11/27/95 (M. Xue)
! Options to compress using gzip and compress.
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
CHARACTER (LEN=*) :: filename
CHARACTER (LEN=132) :: CHAR
INTEGER :: lenstr,ishell,istat
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
lenstr = LEN( filename )
CALL strlnth
( filename, lenstr)
CHAR = 'gzip --fast '
CHAR(13:12+lenstr) = filename
IF( 12+lenstr > 132) THEN
WRITE(6,'(1x,a)') &
'Work character char too small in CMPRS, call returned.'
END IF
WRITE(6,'(1x,a,a,a)') 'Compressing file ',filename,' ...'
istat = ishell( CHAR(1:12+lenstr) )
IF( istat /= 0) THEN
CHAR = 'compress '
CHAR(10:9+lenstr) = filename
istat = ishell( CHAR(1:9+lenstr) )
IF( istat /= 0) WRITE(6,'(1x,a,a,a)') &
'Compression of file ',filename(1:lenstr), &
' was unsucessful in CMPRS.'
END IF
RETURN
END SUBROUTINE cmprs
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE UNCMPRS ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE uncmprs(filename) 14,9
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Make a system call to uncompress the file 'filename' with gunzip
! format developed by Free Software Foundation.
!
!-----------------------------------------------------------------------
!
! Author: Ming Xue
! Date: 11/30/93
!
! MODIFICATION HISTORY:
!
! 9/1/94 (Y. Lu)
! Cleaned up documentation.
!
! 11/27/1995 (M. Xue)
! Decompression for both .Z and .gz files.
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
CHARACTER (LEN=*) :: filename
CHARACTER (LEN=132) :: CHAR
INTEGER :: lenstr,lenfn,ishell,istat
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
lenfn = LEN( filename )
CALL strlnth( filename, lenfn)
lenstr=lenfn
IF(filename(lenstr-1:lenstr) == '.Z') THEN
CHAR = 'uncompress '
CHAR(12:12+lenstr) = filename
lenstr=lenstr+12
ELSE IF(filename(lenstr-2:lenstr) == '.gz') THEN
CHAR = 'gunzip '
CHAR(8:7+lenstr) = filename
lenstr = lenstr+8
ELSE
WRITE(6,'(1x,a,/1x,a)') &
'File name does not have the right affix.', &
'No decompressing was done on file ',filename
RETURN
END IF
IF( lenstr > 132 ) THEN
WRITE(6,'(1x,a)') &
'Work character char too small in UNCMPRS, call returned.'
END IF
WRITE(6,'(1x,a,a,a)') 'Decompressing file ',filename,' ...'
istat = ishell( CHAR(1:lenstr) )
IF( istat /= 0) WRITE(6,'(1x,a,a,a)') &
'Compression of file ',filename(1:lenfn), &
' was unsucessful in CMPRS.'
RETURN
END SUBROUTINE uncmprs
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE GRBSBYTE ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE grbsbyte(iout,in,iskip,nbits) 2
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! SBYTE - Insert a number of bit fields. Cray routine.
!
! Reverses the action of gbytes, taking fields from s and
! inserting them into a bit string in d. see GBYTE.
!
!-----------------------------------------------------------------------
!
! AUTHOR: D. Robertson
! Aug. 1981
! MODIFICATIONS:
!
! 12/05/95 (Yuhe Liu)
! Converted to ARPS standard format and added documents
!
!-----------------------------------------------------------------------
!
! INPUT:
!
! in Integer array to be packed
! iskip
! nbits bits number of packing
!
! OUTPUT:
!
! iout Packed stream
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: in
INTEGER :: nbits
INTEGER :: iskip
INTEGER :: iout(*)
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
INTEGER :: nbpw
PARAMETER (nbpw=64)
INTEGER :: iw, id
INTEGER :: iskip1, ibits
INTEGER :: icon, INDEX
INTEGER :: mask, msk
INTEGER :: movel, iwords
INTEGER :: itemp
INTEGER :: sh1,sh2,sh3
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
id = 1 + iskip/nbpw
iskip1 = MOD(iskip,nbpw)
sh1 = iskip1 + nbits
IF (sh1 > nbpw) GO TO 50
sh2 = nbpw - sh1
IF (sh2 < 0) sh2 = nbpw-sh2
!
!-----------------------------------------------------------------------
!
! Byte goes into 1 word of iout.
!
!-----------------------------------------------------------------------
!
iout(1) = shift( OR( AND(shift(iout(1),sh1),mask(nbpw-nbits)), &
AND(in,shift(mask(nbits),nbits))),sh2)
RETURN
50 CONTINUE
!
!-----------------------------------------------------------------------
!
! Byte goes into 2 words of iout.
!
!-----------------------------------------------------------------------
!
sh3 = 2*nbpw-sh1
iout(1) = OR( AND(iout(id),mask(iskip1)), &
AND(shift(in,sh3),compl(mask(iskip1))) )
iout(2) = OR( AND(iout(id+1),shift(compl(mask(sh1-nbpw)),nbpw)), &
shift(AND(in,compl(mask(sh3))),sh3) )
RETURN
END SUBROUTINE grbsbyte
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE GRBSBYTES ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE grbsbytes(iout,in,iskip,nbits,nskip,nwrd) 1,1
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! SBYTES - Insert a number of bit fields. Cray routine.
!
! Reverses the action of gbytes, taking fields from s and
! inserting them into a bit string in d. see GBYTES.
!
!-----------------------------------------------------------------------
!
! AUTHOR: D. Robertson
! Aug. 1981
! MODIFICATIONS:
!
! 12/05/95 (Yuhe Liu)
! Converted to ARPS standard format and added documents
!
!-----------------------------------------------------------------------
!
! INPUT:
!
! nwrd Number of word to be packed
! in Integer array to be packed
! iskip
! nbits bits number of packing
! nskip
!
! OUTPUT:
!
! iout Packed stream
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nwrd
INTEGER :: in(nwrd)
INTEGER :: nbits
INTEGER :: iskip
INTEGER :: nskip
INTEGER :: iout(nwrd)
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
INTEGER :: nbpw
PARAMETER (nbpw=64)
INTEGER :: iw, id
INTEGER :: iskip1,ibits
INTEGER :: icon, INDEX
INTEGER :: mask, msk
INTEGER :: movel, iwords, istep
INTEGER :: itemp
INTEGER :: sh1,sh2,sh3
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
id = 1 + iskip/nbpw
iskip1 = MOD(iskip,nbpw)
istep = nskip + nbits
DO iw=1,nwrd
sh1 = iskip1 + nbits
IF (sh1 > nbpw) GO TO 50
sh2 = nbpw - sh1
IF (sh2 < 0) sh2 = nbpw-sh2
!
!-----------------------------------------------------------------------
!
! Byte goes into 1 word of iout.
!
!-----------------------------------------------------------------------
!
iout(id) = shift(OR(AND(shift(iout(id),sh1),mask(nbpw-nbits)), &
AND(in(iw),shift(mask(nbits),nbits))),sh2)
GO TO 65
50 CONTINUE
!
!-----------------------------------------------------------------------
!
! Byte goes into 2 words of iout.
!
!-----------------------------------------------------------------------
!
sh3 = 2*nbpw-sh1
iout(id) = OR( AND(iout(id),mask(iskip1)), &
AND(shift(in(iw),sh3),compl(mask(iskip1))) )
iout(id+1) = OR( AND(iout(id+1),shift(compl(mask(sh1-nbpw)), &
nbpw)), &
shift(AND(in(iw),compl(mask(sh3))),sh3) )
65 CONTINUE
!
!-----------------------------------------------------------------------
!
! Update starting word and bit position
!
!-----------------------------------------------------------------------
!
iskip1 = iskip1 + istep
IF (iskip1 < nbpw) CYCLE
iskip1 = iskip1 - nbpw
id = id + 1 + iskip1/nbpw
iskip1 = MOD(iskip1,nbpw)
END DO
RETURN
END SUBROUTINE grbsbytes
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE GRBGBYTE ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE grbgbyte(in,iout,iskip,nbits) 156
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! GBYTE - Extract a number of bit fields. Cray routine.
!
! IN is bit string of indefinite length. Gbytes will
! extract a bitstrings, nbits bits long, and store them
! right justified 0 fill, into successive words of d. The
! successive bitstrings start at bit positions
!
! iskip+1+(iw-1)*(nbits+nskip)
!
! In the bit string s. i.e. skip iskip bits at the start,
! and nskip bits between the extracted strings.
! Bit iskp+1 in a string is found in word is=1+iskip/nbpw in IN,
! where nbpw is the number of bits per word. the starting bit
! is found by skipping mod(iskp,nbpw) bits in that word.
!
!-----------------------------------------------------------------------
!
! AUTHOR: D. Robertson
! Aug. 1981
! MODIFICATIONS:
!
! 12/05/95 (Yuhe Liu)
! Converted to ARPS standard format and added documents
!
!-----------------------------------------------------------------------
!
! INPUT:
!
! in Integer array to be packed
! iskip
! nbits bits number of packing
!
! OUTPUT:
!
! iout Packed stream
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: in(*)
INTEGER :: nbits
INTEGER :: iskip
INTEGER :: iout
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
INTEGER :: nbpw
PARAMETER (nbpw=64)
INTEGER :: iw, id
INTEGER :: iskip1, ibits
INTEGER :: icon, INDEX
INTEGER :: mask, msk
INTEGER :: movel, iwords
INTEGER :: itemp
INTEGER :: sh1,sh2,sh3
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
id = 1 + iskip/nbpw
iskip1 = MOD(iskip,nbpw)
sh1 = iskip1 + nbits
IF(sh1 > nbpw) GO TO 50
!
!-----------------------------------------------------------------------
!
! Byte comes fromm 1 word of IN
!
!-----------------------------------------------------------------------
!
iout = AND( shift(in(id),sh1), shift(mask(nbits),nbits) )
RETURN
50 CONTINUE
sh1 = sh1 - nbpw
!
!-----------------------------------------------------------------------
!
! Byte comes from 2 words of IN.
!
!-----------------------------------------------------------------------
!
iout = OR( shift(AND(in(id),compl(mask(iskip1))),sh1), &
shift(AND(in(id+1),mask(sh1)),sh1) )
RETURN
END SUBROUTINE grbgbyte
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE GRBGBYTES ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE grbgbytes(in,iout,iskip,nbits,nskip,nwrd) 7
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! GBYTES - Extract a number of bit fields. Cray routine.
!
! IN is bit string of indefinite length. Gbytes will
! extract nwrd bitstrings, nbits bits long, and store them
! right justified 0 fill, into successive words of d. The
! successive bitstrings start at bit positions
!
! iskip+1+(iw-1)*(nbits+nskip)
!
! In the bit string s. i.e. skip iskip bits at the start,
! and nskip bits between the extracted strings.
! Bit iskp+1 in a string is found in word is=1+iskip/nbpw in IN,
! where nbpw is the number of bits per word. the starting bit
! is found by skipping mod(iskp,nbpw) bits in that word.
!
!-----------------------------------------------------------------------
!
! AUTHOR: D. Robertson
! Aug. 1981
! MODIFICATIONS:
!
! 12/05/95 (Yuhe Liu)
! Converted to ARPS standard format and added documents
!
!-----------------------------------------------------------------------
!
! INPUT:
!
! nwrd Number of word to be packed
! in Integer array to be packed
! iskip
! nbits bits number of packing
! nskip
!
! OUTPUT:
!
! iout Packed stream
!
!-----------------------------------------------------------------------
!
! Variable Declarations.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nwrd
INTEGER :: in(nwrd)
INTEGER :: nbits
INTEGER :: iskip
INTEGER :: nskip
INTEGER :: iout(nwrd)
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
INTEGER :: nbpw
PARAMETER (nbpw=64)
INTEGER :: iw, id
INTEGER :: iskip1,ibits
INTEGER :: icon, INDEX
INTEGER :: mask, msk
INTEGER :: movel, iwords, istep
INTEGER :: itemp
INTEGER :: sh1,sh2,sh3
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
id = 1 + iskip/nbpw
iskip1 = MOD(iskip,nbpw)
istep = nskip + nbits
DO iw=1,nwrd
sh1 = iskip1 + nbits
IF(sh1 > nbpw) GO TO 50
!
!-----------------------------------------------------------------------
!
! Byte comes fromm 1 word of IN
!
!-----------------------------------------------------------------------
!
iout(iw) = AND( shift(in(id),sh1), shift(mask(nbits),nbits) )
GO TO 65
50 CONTINUE
sh1 = sh1 - nbpw
!
!-----------------------------------------------------------------------
!
! Byte comes from 2 words of IN.
!
!-----------------------------------------------------------------------
!
iout(iw) = OR( shift(AND(in(id),compl(mask(iskip1))),sh1), &
shift(AND(in(id+1),mask(sh1)),sh1) )
65 CONTINUE
!
!-----------------------------------------------------------------------
!
! Update starting word and bit position
!
!-----------------------------------------------------------------------
!
iskip1 = iskip1 + istep
IF(iskip1 < nbpw) CYCLE
iskip1 = iskip1 - nbpw
id = id + 1 + iskip1/nbpw
iskip1 = MOD(iskip1,nbpw)
END DO
RETURN
END SUBROUTINE grbgbytes
REAL FUNCTION f_cputime() 31
!------------------------------------------------------------------------------
! CRAY DEFINITION FOR TIMING
!------------------------------------------------------------------------------
f_cputime = second()
RETURN
END FUNCTION f_cputime
INTEGER FUNCTION lnblnk(str),3
CHARACTER (LEN=*) :: str
lnblnk = LEN(str)
CALL strlnth( str, lnblnk)
RETURN
END FUNCTION lnblnk