c----------------------------------------------------------------------- c c F O R T R A N 7 7 G F 3 <---> H D F R O U T I N E S c c----------------------------------------------------------------------- c NOTE: These routines require a version of NSCA-HDF which c implements the SD interface. c----------------------------------------------------------------------- c c Routines designed to be as compatible as possible with c proposed GC BBH F90 data structure. c c See hypertext references ('data structures') in c c http://www.npac.syr.edu/NPAC1/PUB/haupt/bbh.html c c for details. c c---------------------------------------------------------------------- c Author: Matthew W. Choptuik c Institution: The University of Texas at Austin c Date: June 1994 c---------------------------------------------------------------------- c----------------------------------------------------------------------- c F U N C T I O N S A V A I L A B L E c----------------------------------------------------------------------- c (NOTE: All subprograms are integer functions and must be declared c as such by calling routine.) c----------------------------------------------------------------------- c c integer gf3_read_hdf_f77, gf3_write_hdf_f77, c & gf3_read_brief_hdf_f77, gf3_write_brief_hdf_f77, c & gf3_read_shapes_hdf_f77 c integer gf3_rc c c gf3_rc = gf3_read_hdf_f77 ( hdf_name, name, cshape, c1, c2, c3, c & dshape, gf3_data ) c c gf3_rc = gf3_write_hdf_f77( hdf_name, name, cshape, c1, c2, c3, c & dshape, gf3_data) c c gf3_rc = gf3_read_brief_hdf_f77( hdf_name, dshape, gf3_data) c c gf3_rc = gf3_write_brief_hdf_f77(hdf_name, dshape, gf3_data) c c gf3_rc = gf3_read_shapes_hdf_f77 (hdf_name, cshape, dshape) c c----------------------------------------------------------------------- c c with c c character*(*) hdf_name ! Name of hdf file c c character*(*) name ! Print name of grid function c integer cshape(3) ! Lengths of coordinate vectors c real*8 c1(*) ! 'x' coordinates; length = cshape(1) c real*8 c2(*) ! 'y' coordinates; length = cshape(2) c real*8 c3(*) ! 'z' coordinates; length = cshape(3) c integer dshape(3) ! Shape of grid function data c real*8 gf3_data(*) ! Grid function data; read with shape c (dshape(1),dshape(2),dshape(3)) c c----------------------------------------------------------------------- c c gf3_read_f77() and gf3_write_hdf_f77() are intended to read and c write .hdf files containing a *single* 64-bit 3-dimensional grid c function. From the HDF/SDS viewpoint each such file contains c *five* datasets: one for the shape of the data, three for the c vectors of coordinate data and one for the actual grid function c data. c c gf3_read_brief_f77() and gf3_write_brief_f77() are front ends c to the generic routines described above for use when grid c function name () and coordinate information c are ignorable. c c Separate 'true' (dataset 0) and 'stored' (part of dataset 4) c shapes are used. A stored shape of (1,1,1) encodes a constant c grid function of the 'true' shape. c c NOTE: c c o gf3_write_hdf_f77() will complain if HDF file c already exists ... move/remove before execution. c c o User is *always* responsible for ensuring that sufficient c storage is supplied via actual parameters, particularly c for , , and c c In accordance with HDF/XDR convention, routines return 0 for c success, -1 for failure. c c Most of the length of these routines is due to the rather c exhaustive error checking. m4 would clearly help. c c----------------------------------------------------------------------- c----------------------------------------------------------------------- c c Data Set #: Type Shape Description c c 0 I gf3_dshape Shape of grid function c 1 R8 gf3_cshape(1) 'x' coords c 2 R8 gf3_cshape(2) 'y' coords c 3 R8 gf3_cshape(3) 'z' coords c 4 R8 gf3_dshape Grid function c | R8 (1,1,1) Constant grid function c c----------------------------------------------------------------------- c----------------------------------------------------------------------- c FORTRAN 90 description ... c c subroutine gf3_read_hdf(hdf_name,the) c c use bh03 c c character*(*), intent(in) :: hdf_name c TYPE (GF3), intent(out) :: the c c call gf3_read_hdf_f77(hdf_name, the%name, c & the%cshape, the.c(1)%coord, the.c(2)%coord, the.c(3)%coord, c & the%dshape, the%data) c c return c c end c----------------------------------------------------------------------- integer function gf3_read_hdf_f77(hdf_name, gf3_name, & gf3_cshape, gf3_c1, gf3_c2, gf3_c3, gf3_dshape, gf3_data) implicit none include 'hdf.inc' logical gf3_hdf_exists_f77 integer sds_extract_int32, sds_extract_float64 character*(*) hdf_name, gf3_name integer gf3_cshape(3), gf3_dshape(3) real*8 gf3_c1(*), gf3_c2(*), & gf3_c3(*), gf3_data(*) integer sd_id, sds_id, sd_rc, sd_rank, & sd_ntype c----------------------------------------------------------------------- c Local shape for use in compressing constant grid function ... c----------------------------------------------------------------------- integer l_gf3_dshape(3) c----------------------------------------------------------------------- c Miscellaneous local shape storage ... c----------------------------------------------------------------------- integer exp_shape(7), l_shape(7) c----------------------------------------------------------------------- c Local vector for storing ignored/undefined strings ... c----------------------------------------------------------------------- character*128 l_buffer c----------------------------------------------------------------------- integer ds_shape, ds_x, & ds_y, ds_z, & ds_gfcn parameter ( ds_shape = 0, ds_x = 1, & ds_y = 2, ds_z = 3, & ds_gfcn = 4 ) c----------------------------------------------------------------------- c Kludge for communication with C routine ... c----------------------------------------------------------------------- integer gf3_indlnb integer name_len common / com_gf3 / name_len c----------------------------------------------------------------------- c If the requested HDF file exists ... c----------------------------------------------------------------------- if( gf3_hdf_exists_f77(hdf_name) ) then c----------------------------------------------------------------------- c Get an id # for use with the SD interface ... c----------------------------------------------------------------------- sd_id = sfstart(hdf_name,dfacc_rdonly) if( sd_id .lt. 0 ) then call gf3_perror_f77('gf3_read_hdf_f77', & 'Unexpected failure of sfstart') gf3_read_hdf_f77 = fail return end if c----------------------------------------------------------------------- c Get shape ... c----------------------------------------------------------------------- exp_shape(1) = 3 gf3_read_hdf_f77 = sds_extract_int32(sd_id,ds_shape, & 1,exp_shape,l_buffer,sd_rank,l_shape,gf3_dshape) if( gf3_read_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get 'x' coordinates ... c----------------------------------------------------------------------- exp_shape(1) = -1 gf3_read_hdf_f77 = sds_extract_float64(sd_id,ds_x, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(1),gf3_c1) if( gf3_read_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get 'y' coordinates ... c----------------------------------------------------------------------- exp_shape(1) = -1 gf3_read_hdf_f77 = sds_extract_float64(sd_id,ds_y, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(2),gf3_c2) if( gf3_read_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get 'z' coordinates ... c----------------------------------------------------------------------- exp_shape(1) = -1 gf3_read_hdf_f77 = sds_extract_float64(sd_id,ds_z, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(3),gf3_c3) if( gf3_read_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get grid function data ... c----------------------------------------------------------------------- exp_shape(1) = -1 call gf3_sload(l_buffer,' ') gf3_read_hdf_f77 = sds_extract_float64(sd_id,ds_gfcn, & 3,exp_shape,l_buffer,sd_rank,l_gf3_dshape,gf3_data) if( gf3_read_hdf_f77 .ne. succeed ) return name_len = max(1,gf3_indlnb(l_buffer)) gf3_name = l_buffer c----------------------------------------------------------------------- c Convert constant function ... c----------------------------------------------------------------------- if( l_gf3_dshape(1) .eq. 1 .and. l_gf3_dshape(2) .eq. 1 & .and. l_gf3_dshape(3) .eq. 1 ) then call gf3_ls(gf3_dshape,gf3_data,gf3_data(1)) end if sd_rc = sfendacc(sds_id) c----------------------------------------------------------------------- c Finish up ... c----------------------------------------------------------------------- sd_rc = sfend(sd_id) if( sd_rc .eq. succeed) then gf3_read_hdf_f77 = succeed else call gf3_perror_f77('gf3_read_hdf_f77', & 'Unexpected failure of sdend') gf3_read_hdf_f77 = fail return end if else gf3_read_hdf_f77 = fail return end if return end c----------------------------------------------------------------------- c FORTRAN 90 description ... c c subroutine gf3_write_hdf(hdf_name,the) c c use bh03 c c character*(*), intent(in) :: hdf_name c TYPE (GF3), intent(in) :: the c c call gf3__hdf_f7 d(hdf_name, the%name, c & the%cshape, the.c(1)%coord, the.c(2)%coord, the.c(3)%coord, c & the%dshape, the%data) c c return c c end c----------------------------------------------------------------------- integer function gf3_write_hdf_f77(hdf_name, gf3_name, & gf3_cshape, gf3_c1, gf3_c2, gf3_c3, gf3_dshape, gf3_data) implicit none include 'hdf.inc' logical gf3_hdf_exists_f77, & gf3_is_constant integer sds_append_int32, sds_append_float64 character*(*) hdf_name, gf3_name integer gf3_cshape(3), gf3_dshape(3) real*8 gf3_c1(*), gf3_c2(*), & gf3_c3(*), gf3_data(*) integer sd_id integer l_shape(7), ishape integer start(3), stride(3) c----------------------------------------------------------------------- c If the requested HDF file does not exist ... c----------------------------------------------------------------------- if( .not. gf3_hdf_exists_f77(hdf_name) ) then c----------------------------------------------------------------------- c Get an id # for use with the SD interface ... c----------------------------------------------------------------------- sd_id = sfstart(hdf_name,dfacc_create) if( sd_id .eq. fail ) then call gf3_perror_f77('gf3_write_hdf_f77', & 'Unexpected failure of sfstart()') gf3_write_hdf_f77 = fail return end if c----------------------------------------------------------------------- c Put shape ... c----------------------------------------------------------------------- l_shape(1) = 3 gf3_write_hdf_f77 = sds_append_int32(sd_id, & 'Shape',1,l_shape,gf3_dshape) if( gf3_write_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Put 'x' coordinates ... c----------------------------------------------------------------------- l_shape(1) = gf3_cshape(1) gf3_write_hdf_f77 = sds_append_float64(sd_id, & 'Coord. 1 (x)',1,l_shape,gf3_c1) if( gf3_write_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Put 'y' coordinates ... c----------------------------------------------------------------------- l_shape(1) = gf3_cshape(2) gf3_write_hdf_f77 = sds_append_float64(sd_id, & 'Coord. 2 (y)',1,l_shape,gf3_c2) if( gf3_write_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Put 'z' coordinates ... c----------------------------------------------------------------------- l_shape(1) = gf3_cshape(3) gf3_write_hdf_f77 = sds_append_float64(sd_id, & 'Coord. 3 (z)',1,l_shape,gf3_c3) if( gf3_write_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Put grid function data ... check to see if grid function c is a constant ... if it is only store the single, constant c value (dshape := (1,1,1)) c----------------------------------------------------------------------- if( gf3_is_constant(gf3_dshape,gf3_data) ) then do ishape = 1 , 3 l_shape(ishape) = 1 end do else do ishape = 1 , 3 l_shape(ishape) = gf3_dshape(ishape) end do end if gf3_write_hdf_f77 = sds_append_float64(sd_id, & gf3_name,3,l_shape,gf3_data) if( gf3_write_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Finish up ... c----------------------------------------------------------------------- gf3_write_hdf_f77 = sfend(sd_id) if( gf3_write_hdf_f77 .eq. fail) then call gf3_perror_f77('gf3_write_hdf_f77', & 'Unexpected failure of sdend') return end if else gf3_write_hdf_f77 = fail end if return end c----------------------------------------------------------------------- c c gf3_read_brief_hdf_f77() and gf3_write_brief_hdf_f77() depend c on specific output order specified above due to 'overloading' c of parameters to gf3_read_hdf_f77() and gf3_write_hdf_f77(). c c----------------------------------------------------------------------- integer function gf3_read_brief_hdf_f77(hdf_name, & gf3_dshape,gf3_data) implicit none include 'hdf.inc' integer gf3_read_hdf_f77 character*(*) hdf_name integer gf3_dshape(3) real*8 gf3_data(*) character*64 gf3_name parameter ( gf3_name = 'Unnamed' ) integer gf3_cshape(3) gf3_read_brief_hdf_f77 = gf3_read_hdf_f77(hdf_name,gf3_name, & gf3_cshape,gf3_data,gf3_data,gf3_data,gf3_dshape,gf3_data) return end c----------------------------------------------------------------------- integer function gf3_write_brief_hdf_f77(hdf_name, & gf3_dshape,gf3_data) implicit none include 'hdf.inc' integer gf3_write_hdf_f77 character*(*) hdf_name integer gf3_dshape(3) real*8 gf3_data(*) integer gf3_cshape(3) real*8 gf3_c_i(2) save data gf3_cshape / 2, 2, 2 / data gf3_c_i / 0.0d0, 1.0d0 / gf3_write_brief_hdf_f77 = gf3_write_hdf_f77(hdf_name,hdf_name, & gf3_cshape,gf3_c_i,gf3_c_i,gf3_c_i,gf3_dshape,gf3_data) return end c----------------------------------------------------------------------- c c Get shape information so that calling routine can do appropriate c memory allocation or checking ... c c----------------------------------------------------------------------- integer function gf3_read_shapes_hdf_f77(hdf_name, & gf3_cshape, gf3_dshape) implicit none include 'hdf.inc' logical gf3_hdf_exists_f77 integer sds_extract_int32, sds_extract_float64 character*(*) hdf_name integer gf3_cshape(3), gf3_dshape(3) integer sd_id, sds_id, sd_rc, sd_rank, & sd_ntype c----------------------------------------------------------------------- c Local shape for use in compressing constant grid function ... c----------------------------------------------------------------------- integer l_gf3_dshape(3) c----------------------------------------------------------------------- c Miscellaneous local shape storage ... c----------------------------------------------------------------------- integer exp_shape(7), l_shape(7) c----------------------------------------------------------------------- c Local vector for storing ignored/undefined strings ... c----------------------------------------------------------------------- character*128 l_buffer c----------------------------------------------------------------------- c (Unused) storage for number of NETCDF attributes ... c----------------------------------------------------------------------- integer netcdf_nattr integer start(3), stride(3) integer ds_shape, ds_x, & ds_y, ds_z, & ds_gfcn parameter ( ds_shape = 0, ds_x = 1, & ds_y = 2, ds_z = 3, & ds_gfcn = 4 ) save start, stride data start / 0, 0, 0 /, & stride / 1, 1, 1 / c----------------------------------------------------------------------- c If the requested HDF file exists ... c----------------------------------------------------------------------- if( gf3_hdf_exists_f77(hdf_name) ) then c----------------------------------------------------------------------- c Get an id # for use with the SD interface ... c----------------------------------------------------------------------- sd_id = sfstart(hdf_name,dfacc_rdonly) if( sd_id .lt. 0 ) then call gf3_perror_f77('gf3_read_shapes_hdf_f77', & 'Unexpected failure of sfstart') gf3_read_shapes_hdf_f77 = fail return end if c----------------------------------------------------------------------- c Get shape ... c----------------------------------------------------------------------- exp_shape(1) = 3 gf3_read_shapes_hdf_f77 = sds_extract_int32(sd_id,ds_shape, & 1,exp_shape,l_buffer,sd_rank,l_shape,gf3_dshape) if( gf3_read_shapes_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get cshape(1) ( nx ) ... c----------------------------------------------------------------------- exp_shape(1) = 0 gf3_read_shapes_hdf_f77 = sds_extract_float64(sd_id,ds_x, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(1),l_buffer) if( gf3_read_shapes_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get cshape(1) ( ny ) ... c----------------------------------------------------------------------- exp_shape(1) = 0 gf3_read_shapes_hdf_f77 = sds_extract_float64(sd_id,ds_y, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(2),l_buffer) if( gf3_read_shapes_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Get cshape(1) ( nz ) ... c----------------------------------------------------------------------- exp_shape(1) = 0 gf3_read_shapes_hdf_f77 = sds_extract_float64(sd_id,ds_z, & 1,exp_shape,l_buffer,sd_rank,gf3_cshape(3),l_buffer) if( gf3_read_shapes_hdf_f77 .ne. succeed ) return c----------------------------------------------------------------------- c Finish up ... c----------------------------------------------------------------------- sd_rc = sfend(sd_id) if( sd_rc .eq. succeed) then gf3_read_shapes_hdf_f77 = succeed else call gf3_perror_f77('gf3_read_shapes_hdf_f77', & 'Unexpected failure of sdend') gf3_read_shapes_hdf_f77 = fail return end if else gf3_read_shapes_hdf_f77 = fail return end if return end c----------------------------------------------------------------------- c c Factored routines for appending 4-byte integer and 8-byte real c SDS's to HDF file ... c c----------------------------------------------------------------------- integer function sds_append_int32(sd_id,name,rank,shape,data) implicit none include 'hdf.inc' integer gf3_indlnb integer sd_id integer rank, shape(*) integer data(*) character*(*) name character*256 lname integer start(3), stride(3) integer sd_rc save start, stride data start / 0, 0, 0 /, & stride / 1, 1, 1 / call gf3_sload(lname,' ') lname = name sds_append_int32 = sfcreate(sd_id,lname(1:gf3_indlnb(lname)), & dfnt_int32,rank,shape) if( sds_append_int32 .eq. fail ) then call gf3_perror_f77('sds_append_int32', & 'Unexpected failure of sfcreate('// * lname(1:gf3_indlnb(lname))//')') return end if sd_rc = sfwdata(sds_append_int32,start,stride,shape,data) if( sd_rc .ne. succeed ) then call gf3_perror_f77('sds_append_int32', & 'Unexpected failure of sfwdata()') sds_append_int32 = fail return end if sds_append_int32 = sfendacc(sds_append_int32) return end integer function sds_append_float64(sd_id,name,rank,shape,data) implicit none include 'hdf.inc' integer gf3_indlnb integer sd_id integer rank, shape(*) real*8 data(*) character*(*) name character*256 lname integer start(3), stride(3) integer sd_rc save start, stride data start / 0, 0, 0 /, & stride / 1, 1, 1 / call gf3_sload(lname,' ') lname = name sds_append_float64 = sfcreate(sd_id,lname(1:gf3_indlnb(lname)), & dfnt_float64,rank,shape) if( sds_append_float64 .eq. fail ) then call gf3_perror_f77('sds_append_float64', & 'Unexpected failure of sfcreate('// * lname(1:gf3_indlnb(lname))//')') return end if sd_rc = sfwdata(sds_append_float64,start,stride,shape,data) if( sd_rc .ne. succeed ) then call gf3_perror_f77('sds_append_float64', & 'Unexpected failure of sfwdata()') sds_append_float64 = fail return end if sds_append_float64 = sfendacc(sds_append_float64) return end c----------------------------------------------------------------------- c c Factored routines for extracting 4-byte integer and 8-byte real c SDS's to HDF file ... c c Set expected_rank, expected_shape < 0 if no expectations ... c Set expected shape = 0 to skip data read ... c c----------------------------------------------------------------------- integer function sds_extract_int32(sd_id,sds_num, & expected_rank,expected_shape, & name,rank,shape,data) implicit none include 'hdf.inc' integer gf3_indlnb integer sd_id, sds_num, expected_rank, & expected_shape(*) character*(*) name integer rank, shape(*) integer data(*) integer start(3), stride(3) integer sds_id, sd_ntype, sd_rc, & netcdf_nattr, ishape save start, stride data start / 0, 0, 0 /, & stride / 1, 1, 1 / sds_id = sfselect(sd_id,sds_num) sd_rc = sfginfo(sds_id,name,rank,shape,sd_ntype,netcdf_nattr) if( expected_rank .ge. 0 .and. & rank .ne. expected_rank ) then call gf3_perror_f77('sds_extract_int32', & 'Data set does not have expected rank') sds_extract_int32 = fail return end if if( expected_shape(1) .eq. 0 ) then sds_extract_int32 = succeed return end if if( expected_shape(1) .ge. 0 ) then do ishape = 1 , rank if( shape(ishape) .ne. expected_shape(ishape) ) then call gf3_perror_f77('sds_extract_int32', & 'Data set does not have expected shape') sds_extract_int32 = fail return end if end do end if if( sd_ntype .ne. dfnt_int32 ) then call gf3_perror_f77('sds_extract_int32', & 'Number type of dataset .ne. dfnt_int32') sds_extract_int32 = fail return end if sd_rc = sfrdata(sds_id,start,stride,shape,data) sds_extract_int32 = sfendacc(sds_id) return end integer function sds_extract_float64(sd_id,sds_num, & expected_rank,expected_shape, & name,rank,shape,data) implicit none include 'hdf.inc' integer gf3_indlnb integer sd_id, sds_num, expected_rank, & expected_shape(*) integer rank, shape(*) real*8 data(*) character*(*) name integer start(3), stride(3) integer sds_id, sd_ntype, sd_rc, & netcdf_nattr, ishape save start, stride data start / 0, 0, 0 /, & stride / 1, 1, 1 / sds_id = sfselect(sd_id,sds_num) sd_rc = sfginfo(sds_id,name,rank,shape,sd_ntype,netcdf_nattr) if( expected_rank .ge. 0 .and. & rank .ne. expected_rank ) then call gf3_perror_f77('sds_extract_float64', & 'Data set does not have expected rank') sds_extract_float64 = fail return end if if( expected_shape(1) .eq. 0 ) then sds_extract_float64 = succeed return end if if( expected_shape(1) .ge. 0 ) then do ishape = 1 , rank if( shape(ishape) .ne. expected_shape(ishape) ) then call gf3_perror_f77('sds_extract_float64', & 'Data set does not have expected shape') sds_extract_float64 = fail return end if end do end if if( sd_ntype .ne. dfnt_float64 ) then call gf3_perror_f77('sds_extract_float64', & 'Number type of dataset .ne. dfnt_float64') sds_extract_float64 = fail return end if sd_rc = sfrdata(sds_id,start,stride,shape,data) sds_extract_float64 = sfendacc(sds_id) return end c----------------------------------------------------------------------- c c Predicate: Does an HDF (netCDF) file with name hdf_name exist? c c----------------------------------------------------------------------- logical function gf3_hdf_exists_f77(hdf_name) implicit none include 'hdf.inc' character*(*) hdf_name integer sd_id sd_id = sfstart(hdf_name,dfacc_rdonly) if( sd_id .ge. 0 ) then gf3_hdf_exists_f77 = .true. sd_id = sfend(sd_id) else gf3_hdf_exists_f77 = .false. end if return end c----------------------------------------------------------------------- c c Predicate: Is 3-grid function constant? c c----------------------------------------------------------------------- logical function gf3_is_constant(dshape,gf3) implicit none integer dshape(3) real*8 gf3(dshape(1),dshape(2),dshape(3)) integer i, j, k gf3_is_constant =.true. do k = 1 , dshape(3) do j = 1 , dshape(2) do i = 1 , dshape(1) if( gf3(i,j,k) .ne. gf3(1,1,1) ) then gf3_is_constant = .false. return end if end do end do end do return end c----------------------------------------------------------------------- c c Load 3-grid with constant ... c c----------------------------------------------------------------------- subroutine gf3_ls(dshape,gf3,sc) implicit none integer dshape(3) real*8 gf3(dshape(1),dshape(2),dshape(3)) real*8 sc integer i, j, k do k = 1 , dshape(3) do j = 1 , dshape(2) do i = 1 , dshape(1) gf3(i,j,k) = sc end do end do end do return end c----------------------------------------------------------------------- c c Error message utility. c c----------------------------------------------------------------------- subroutine gf3_perror_f77(routine,message) implicit none character*(*) routine, message integer stderr parameter ( stderr = 0 ) write(stderr,1000) routine, message 1000 format(a,': ',a) return end c----------------------------------------------------------------------- c c Dumps 3-grid on unit c c----------------------------------------------------------------------- subroutine gf3_dump(dshape,gf3,label,unit) implicit none integer dshape(3), unit real*8 gf3(dshape(1),dshape(2),dshape(3)) character*(*) label integer i, j, & k, st if( min(dshape(1),dshape(2),dshape(3)) .gt. 0 ) then write(unit,100) label 100 format(/' <<< ',a,' >>>') do k = 1 , dshape(3) write(unit,105) k 105 format(' <<< Plane: ',i4,'. >>>') do j = 1 , dshape(2) st = 1 110 continue write(unit,120) ( gf3(i,j,k) , & i = st , min(st+3,dshape(1)) ) 120 format(' ',4(1pe19.10)) st = st + 4 if( st .le. dshape(1) ) go to 110 write(unit,*) end do end do end if return end c----------------------------------------------------------------------- c c Local versions of string utilities ... c c----------------------------------------------------------------------- integer function gf3_indlnb(s) implicit none character*(*) s integer i do gf3_indlnb = len(s) , 1 , -1 if( s(gf3_indlnb:gf3_indlnb) .ne. ' ' ) return end do gf3_indlnb = 0 return end subroutine gf3_sload(s,c) implicit none character*(*) s character*1 c integer i do i = 1 , len(s) s(i:i) = c end do return end