test_checkpoint_mpiio.f90

做网格的好程序

              enddo
 
              do j=1+nguard0,nyb+nguard0+1
                y0 = coord(2,l)-.5*bsize(2,l)-dy
                yj = y0 + dy*real(j-nguard0)
                do i=1+nguard0,nxb+nguard0+1
                  x0 = coord(1,l)-.5*bsize(1,l)-dx
                  xi = x0 + dx*real(i-nguard0)
                  do k=1+nguard0*k3d,nzb+nguard0*k3d
                    if(ndim.eq.3) z0 = coord(3,l)-.5*(bsize(3,l)+dz)
                    zk = z0 + dz*real(k-nguard0)
                    do ivar=1,nvaredge
                      value = ax*xi+ay*yj+az*zk
                      unk_e_z(ivar,i,j,k,l)=value*real(ivar)
                    enddo
                  enddo
                enddo
              enddo
 
        endif

      enddo

      endif

      Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      loop_count=0
! Now cycle over blocks adjusting refinement of initial setup as required
        do while(loop_count.lt.3)


        refine(:) = .false.
      if(loop_count.lt.2) then
       refine(:) = .true.
      elseif(loop_count.eq.2) then
      if(ndim.eq.3) then
       do l=1,lnblocks
       if( coord(1,l).eq..125.and.coord(2,l).eq..125.and. & 
     &       coord(3,l).eq..125) refine(l)=.true.
       if( coord(1,l).eq..375.and.coord(2,l).eq..375.and. & 
     &       coord(3,l).eq..375) refine(l)=.true.
       if( coord(1,l).eq..625.and.coord(2,l).eq..875.and. & 
     &       coord(3,l).eq..875) refine(l)=.true.
       enddo
      elseif(ndim.eq.2) then
                do l=1,lnblocks
                if( coord(1,l).eq..125.and.coord(2,l).eq..125) & 
     &                 refine(l)=.true.
                if( coord(1,l).eq..375.and.coord(2,l).eq..375) & 
     &                 refine(l)=.true.
                if( coord(1,l).eq..625.and.coord(2,l).eq..875) & 
     &                 refine(l)=.true.
                enddo

      endif
      endif


! refine grid and apply morton reordering to grid blocks if necessary
      call amr_refine_derefine

! a global prolongation call resets the newchild marker flags to false.
! Thus to test prolong for work we will need to restore this after the
! prolongation is applied to unk and facevar's
      tnewchild(:) = newchild(:)

      tag_offset = 100
      call mpi_morton_bnd_prolong1 & 
     &             (mype,nprocs,tag_offset)

      iopt = 1
      nlayers = nguard
      call amr_prolong(mype,iopt,nlayers)
#ifdef DEBUG
       call amr_flush(6)
       call mpi_barrier (MPI_COMM_WORLD, errcode)
       write(*,*) 'exited amr_prolong : pe ',mype, & 
     &    ' loop_count = ',loop_count
       call amr_flush(6)
       call mpi_barrier (MPI_COMM_WORLD, errcode)
#endif /* DEBUG */

#ifdef TEMP_TEST
!-----
      if (.not. advance_all_levels) the
       write(*,*) 'This part not tested '
       write(*,*) 'Should be added in other test programs '
       call mpi_amr_1blk_restrict(mype,iopt,lcc,lfc,lec,lnc,.true.)
       end if
!-----
#endif /* TEMP_TEST */


      if (no_permanent_guardcells) then
! Store a copy of the current solution in gt_unk
      call amr_1blk_copy_soln(-1)
      end if


      tag_offset = 100
      call mpi_morton_bnd(mype,nprocs,tag_offset)

      iopt = 1

      if (.not.no_permanent_guardcells) then


! set guard cell data to zero to ensure proper test of guardcell
! set external guard cell data.
!        call zero_guardcells(ioptw)


      iopt = 1
      nlayers = nguard
      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if(nvar.gt.0) lcc = .true.
      if(nfacevar.gt.0) lfc = .true.
      if(nvaredge.gt.0) lec = .true.
      if(nvarcorn.gt.0) lnc = .true.
      tag_offset = 100
      call amr_guardcell(mype,iopt,nlayers)

      iopt = ioptw
      nlayers = nguard_work
      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if(nvar.gt.0) lcc = .true.
      if(nfacevar.gt.0) lfc = .true.
      if(nvaredge.gt.0) lec = .true.
      if(nvarcorn.gt.0) lnc = .true.
      tag_offset = 100
      call amr_guardcell(mype,iopt,nlayers)

      else                      ! no_permanent_guardcells

      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if(nvar.gt.0) lcc = .true.
      if(nfacevar.gt.0) lfc = .true.
      if(nvaredge.gt.0) lec = .true.
      if(nvarcorn.gt.0) lnc = .true.
      tag_offset = 100
      lguard    = .true.
      lprolong  = .false.
      lflux     = .false.
      ledge     = .false.
      lrestrict = .false.
      lfulltree = .false.
      call mpi_amr_comm_setup(mype,nprocs, & 
     &                        lguard,lprolong,lflux,ledge, & 
     &                        lrestrict,lfulltree, & 
     &                        iopt,lcc,lfc,lec,lnc,tag_offset)

      endif                     ! no_permanent_guardcells

        loop_count=loop_count+1
        write(*,*) 'proc loop_count ',mype,loop_count

        enddo
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        if(mype.eq.0) write(*,*) 'Mesh before checkpointing'
        call amr_flush(101)
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

        do ii=0,nprocs-1
                if(mype.eq.ii) then
                do l=1,lnblocks
                write(*,*) 'proc ',ii,' block ',l,' coord= ', & 
     &                  (coord(icoord,l),icoord=1,ndim), & 
     &                  ' size = ',bsize(1,l)
                write(*,*) 'proc ',ii,' block ',l,' parent= ', & 
     &                  parent(1,l),parent(2,l)
                write(*,*) 'proc ',ii,' block ',l,' nodety= ', & 
     &                  nodetype(l)
                enddo
                endif
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        enddo

! write checkpoint file
        iunit1 = 50
        if(mype.eq.0) write(*,*) 'Calling checkpoint_wr'
        if (no_permanent_guardcells) then
        call amr_checkpoint_wr (iunit1 = iunit1, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = 1., & 
     &                          user_attr_2 = 2., & 
     &                          user_attr_3 = 3., & 
     &                          user_attr_4 = 4., & 
     &                          user_attr_5 = 5.)
        else                      ! no_permanent_guardcells
        l_with_guardcells = .false.
        call amr_checkpoint_wr (iunit1,l_with_guardcells, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = 1., & 
     &                          user_attr_2 = 2., & 
     &                          user_attr_3 = 3., & 
     &                          user_attr_4 = 4., & 
     &                          user_attr_5 = 5.)
        end if                    ! no_permanent_guardcells
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

! write a second file just for fun

        iunit2 = 63
        if(mype.eq.0) write(*,*) 'Calling checkpoint_wr'
        if (no_permanent_guardcells) then
        call amr_checkpoint_wr (iunit1 = iunit2, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = 1., & 
     &                          user_attr_2 = 2., & 
     &                          user_attr_3 = 3., & 
     &                          user_attr_4 = 4., & 
     &                          user_attr_5 = 5.)
        else                      ! no_permanent_guardcells
        l_with_guardcells = .false.
        call amr_checkpoint_wr (iunit2,l_with_guardcells, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = 1., & 
     &                          user_attr_2 = 2., & 
     &                          user_attr_3 = 3., & 
     &                          user_attr_4 = 4., & 
     &                          user_attr_5 = 5.)
        end if                    ! no_permanent_guardcells
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

        if(mype.eq.0) write(*,*) 'Checkpoint file written'
        call amr_flush(101)
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

!
! zero out data structures 
        unk(:,:,:,:,:) = 0.
        unk_n = 0.
        unk_e_x = 0.
        unk_e_y = 0.
        unk_e_z = 0.
        facevarx(:,:,:,:,:) = 0.
        facevary(:,:,:,:,:) = 0.
        facevarz(:,:,:,:,:) = 0.
        work(:,:,:,:,:) = 0.
        lrefine(:)=-1
        nodetype(:)=-1
        coord(:,:)=0.
        bsize(:,:)=0.
        bnd_box(:,:,:)=0.
        lnblocks=-1
        neigh(:,:,:)=-1
        parent(:,:)=-1
        child(:,:,:)=-1
        which_child(:)=-1

! read checkpoint file back in
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        if (no_permanent_guardcells) then
        call amr_checkpoint_re (iunit1 = iunit1, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = user1, & 
     &                          user_attr_2 = user2, & 
     &                          user_attr_3 = user3, & 
     &                          user_attr_4 = user4, & 
     &                          user_attr_5 = user5)
        else                      ! no_permanent_guardcells
        l_with_guardcells = .false.
        call amr_checkpoint_re (iunit1,l_with_guardcells, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = user1, & 
     &                          user_attr_2 = user2, & 
     &                          user_attr_3 = user3, & 
     &                          user_attr_4 = user4, & 
     &                          user_attr_5 = user5)
        end if                    ! no_permanent_guardcells
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        if(mype.eq.0) write(*,*) 'Checkpoint file read back in'
        call amr_flush(101)
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

        if (user1 .ne. 1. .or. & 
     &      user2 .ne. 2. .or. & 
     &      user3 .ne. 3. .or. & 
     &      user4 .ne. 4. .or. & 
     &      user5 .ne. 5.) then

           ierror_tot = ierror_tot + 1

           print *,' ERROR in user attributes !!!! '
           print *,' USERS = ',user1,user2,user3,user4,user5

        end if

! read 2nd checkpoint file back in
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        if (no_permanent_guardcells) then
        call amr_checkpoint_re (iunit1 = iunit2, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = user1, & 
     &                          user_attr_2 = user2, & 
     &                          user_attr_3 = user3, & 
     &                          user_attr_4 = user4, & 
     &                          user_attr_5 = user5)
        else                      ! no_permanent_guardcells
        l_with_guardcells = .false.
        call amr_checkpoint_re (iunit2,l_with_guardcells, & 
     &                          check_format = check_format, & 
     &                          user_attr_1 = user1, & 
     &                          user_attr_2 = user2, & 
     &                          user_attr_3 = user3, & 
     &                          user_attr_4 = user4, & 
     &                          user_attr_5 = user5)
        end if                    ! no_permanent_guardcells
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        if(mype.eq.0) write(*,*) 'Checkpoint file read back in'
        call amr_flush(101)
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

        if (user1 .ne. 1. .or. & 
     &      user2 .ne. 2. .or. & 
     &      user3 .ne. 3. .or. & 
     &      user4 .ne. 4. .or. & 
     &      user5 .ne. 5.) then

           ierror_tot = ierror_tot + 1

           print *,' ERROR in user attributes !!!! '
           print *,' USERS = ',user1,user2,user3,user4,user5

        end if


        if(mype.eq.0) write(*,*) 'Mesh after checkpointing'
        call amr_flush(101)
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)

        do ii=0,nprocs-1
                if(mype.eq.ii) then
                do l=1,lnblocks
                write(*,*) 'proc ',ii,' block ',l,' coord= ', & 
     &                  (coord(icoord,l),icoord=1,ndim), & 
     &                  ' size = ',bsize(1,l)
                write(*,*) 'proc ',ii,' block ',l,' parent= ', & 
     &                  parent(1,l),parent(2,l)
                write(*,*) 'proc ',ii,' block ',l,' nodety= ', & 
     &                  nodetype(l)
                enddo
                endif
        Call MPI_BARRIER(MPI_COMM_WORLD, ierr)
        enddo

! set up data in work
      noff = (nguard_work - nguard)*npgs
      if(noff.ge.0) then
        work(il_bnd+noff:iu_bnd+noff,jl_bnd+noff*k2d:ju_bnd+noff*k2d, & 
     &       kl_bnd+noff*k3d:ku_bnd+noff*k3d,:,ioptw-1) =  & 
     &   unk(1,il_bnd:iu_bnd,jl_bnd:ju_bnd,kl_bnd:ku_bnd,:)
      else
        work(ilw:iuw,jlw:juw,klw:kuw,:,ioptw-1) = & 
     &   unk(1,il_bnd-noff:iu_bnd+noff, & 
     &         jl_bnd-noff*k2d:ju_bnd+noff*k2d, & 
     &         kl_bnd-noff*k3d:ku_bnd+noff*k3d,:)
      endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      if (no_permanent_guardcells) then
! Store a copy of the current solution in gt_unk
      call amr_1blk_copy_soln(-1)
      end if


      tag_offset = 100
      call mpi_morton_bnd(mype,nprocs,tag_offset)

      iopt = 1


      if (.not.no_permanent_guardcells) then

! set guard cell data to zero to ensure proper test of guardcell
! set external guard cell data.
!        call zero_guardcells(ioptw)

        iopt = 1
        nlayers = nguard
      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if (nvar     > 0) lcc = .true.
      if (nfacevar > 0) lfc = .true.
      if (nvaredge > 0) lec = .true.
      if (nvarcorn > 0) lnc = .true.
      tag_offset = 100
      if(.not.l_with_guardcells) call amr_guardcell(mype,iopt,nlayers)

      iopt = ioptw
      nlayers = nguard_work
      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if (nvar     > 0) lcc = .true.
      if (nfacevar > 0) lfc = .true.
      if (nvaredge > 0) lec = .true.
      if (nvarcorn > 0) lnc = .true.
      tag_offset = 100
      call amr_guardcell(mype,iopt,nlayers)

      else                      ! no_permanent_guardcells

      lcc = .false.
      lfc = .false.
      lec = .false.
      lnc = .false.
      if (nvar     > 0) lcc = .true.
      if (nfacevar > 0) lfc = .true.
      if (nvaredge > 0) lec = .true.
      if (nvarcorn > 0) lnc = .true.
      tag_offset = 100
      lguard    = .true.
      lprolong  = .false.
      lflux     = .false.
      ledge     = .false.
      lrestrict = .false.
      lfulltree = .false.