Example Source Code: strout.f

c **********************************************************************
c * strout.f                                                           *
c * Copyright (C) 1997 Dept. of Mathematics, University of Houston     *
c * This is free software; you can use, copy, distribute and/or modify *
c * it freely under the disclaimer that no warranties are offered nor  *
c * liabilities assumed through such actions.                          *
c **********************************************************************
c **********************************************************************
c * This example subroutine simply writes a structured grid            *
c * vertex-centered solution to a file in hhdb format.                 *
c * Please note that this is a skeleton routine intendend for          *
c * demonstration purpose only.                                        *
c **********************************************************************
        subroutine strout(unit,soln,nblks,ndims,grid,
     *                    idim,jdim,kdim,nvars,idata,
     *                    nptchs,ilo,ihi,jlo,jhi,klo,khi,
     *                    bvars,bdata,status)
        implicit logical (a-z)

c   Output variable declarations:
 
        integer    MAGN,
     *             HHDB,EHHDB,
     *             STRUC,ESTRUC,
     *             CC_INT,VC_INT,
     *             CC_BOU,VC_BOU

        parameter (MAGN=1212432974,
     *             HHDB=32,EHHDB=33,
     *             STRUC=66,ESTRUC=67,
     *             CC_INT=257,VC_INT=256,
     *             CC_BOU=259,VC_BOU=258)

        integer    soln,nblks,ndims,nvars,bvars,nptchs,
        real       grid(1),idata(1),bdata(1)

        integer    unit,blk,ptch,
     *             idim(1),jdim(1),kdim(1),
     *             ilo(nblks,1),ihi(nblks,1),jlo(nblks,1),
     *             jhi(nblks,1),klo(nblks,1),khi(nblks,1)
        integer    va,id,i,j,k,status

c   Open the hhdb output file:

        open(unit=unit,file='solution.hhdb',
     *       status='new',form='unformatted',err=2000)

        write(unit) MAGN
        write(unit) HHDB,soln,nblks,ndims,nvars,bvars
        do 20 blk = 1,nblks
          write(unit) STRUC,blk,nptchs
          write(unit) VC_INT,idim(blk),jdim(blk),kdim(blk),
     *      ((((grid(1),id=1,ndims),
     *                  i=1,idim(blk)),
     *                  j=1,jdim(blk)),
     *                  k=1,kdim(blk)),
     *      ((((idata(1),i=1,idim(blk)),
     *                   j=1,jdim(blk)),
     *                   k=1,kdim(blk)),va=1,nvars)
          do 10 ptch = 1,nptchs
            write(unit) VC_BOU,ptch,ilo(blk,ptch),ihi(blk,ptch),
     *                              jlo(blk,ptch),jhi(blk,ptch),
     *                              klo(blk,ptch),khi(blk,ptch),
     *        ((((bdata(1),i=1,ihi(blk,ptch)-ilo(blk,ptch)+1),
     *                     j=1,jhi(blk,ptch)-jlo(blk,ptch)+1),
     *                     k=1,khi(blk,ptch)-klo(blk,ptch)+1),
     *                     va=1,bvars)
10        continue
          write(unit) ESTRUC
20      continue
        write(unit) EHHDB
1000    close(unit=unit)
        print*,'Done writing file.'
        status=0
        return
2000    print*,'Error opening output file'
        status=1
3000    return
        end