testcheck.f90

Go to the documentation of this file.

 
! Copyright (C) 2009 J. K. Dewhurst, S. Sharma and E. K. U. Gross
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
 
subroutine testcheck
implicit none
! local variables
logical exist
integer i,j,k,n
integer nv_,nv,vt_,vt,iv_,iv
real(8) rv_,rv,a,b
real(8) tol,t1,t2
complex(8) zv_,zv
character(256) fname_,fname,descr
n=0
do i=0,999
  write(fname_,'("TEST_",I3.3,".OUT_")') i
  inquire(file=trim(fname_),exist=exist)
  if (exist) then
    write(fname,'("TEST_",I3.3,".OUT")') i
    inquire(file=trim(fname),exist=exist)
    if (.not.exist) then
      write(*,*)
      write(*,'("Error(testcheck): file ",A," does not exist")') trim(fname)
      write(*,*)
      error stop
    end if
    open(91,file=trim(fname_),form='FORMATTED')
    open(92,file=trim(fname),form='FORMATTED')
    read(91,*,err=10) descr
    read(92,*,err=20) descr
    read(91,*,err=10) vt_,nv_
    read(92,*,err=20) vt,nv
    if (vt_ /= vt) then
      write(*,*)
      write(*,'("Error(testcheck): differing variable type")')
      write(*,'(" for quantity ''",A,"''")') trim(descr)
      write(*,'(" ",A," : ",I8)') trim(fname_),vt_
      write(*,'(" ",A,"  : ",I8)') trim(fname),vt
      write(*,*)
      error stop
    end if
    if (nv_ /= nv) then
      write(*,*)
      write(*,'("Error(testcheck): differing number of variables")')
      write(*,'(" for quantity ''",A,"''")') trim(descr)
      write(*,'(" ",A," : ",I8)') trim(fname_),nv_
      write(*,'(" ",A,"  : ",I8)') trim(fname),nv
      write(*,*)
      error stop
    end if
    if (nv < 1) then
      write(*,*)
      write(*,'("Error(testcheck): nv < 1 : ",I8)') nv
      write(*,*)
      error stop
    end if
    if (vt == 1) then
! integer variables
      do j=1,nv
        read(91,*,err=10) k,iv_
        if (j /= k) goto 10
        read(92,*,err=20) k,iv
        if (j /= k) goto 20
        if (iv /= iv_) then
          write(*,*)
          write(*,'("Error(testcheck): variable ",I8," is different")') j
          write(*,'(" for quantity ''",A,"''")') trim(descr)
          write(*,'(" ",A," : ",I8)') trim(fname_),iv_
          write(*,'(" ",A,"  : ",I8)') trim(fname),iv
          write(*,*)
          error stop
        end if
      end do
    else if (vt == 2) then
! real variables
      read(91,*,err=10) tol
      read(92,*,err=20) tol
      do j=1,nv
        read(91,*,err=10) k,rv_
        if (j /= k) goto 10
        read(92,*,err=20) k,rv
        if (j /= k) goto 20
        t1=abs(rv_-rv)
        t2=abs(rv_)*tol
        if ((t1 > t2).and.(abs(rv_) > 1.d-4)) then
          write(*,*)
          write(*,'("Error(testcheck): variable ",I8," outside tolerance")') j
          write(*,'(" for quantity ''",A,"''")') trim(descr)
          write(*,'(" ",A," (correct value)",T40," : ",G24.14)') trim(fname_), &
           rv_
          write(*,'(" ",A,T40," : ",G24.14)') trim(fname),rv
          write(*,'(" absolute difference",T40," : ",G24.14)') t1
          write(*,'(" required relative tolerance",T40," : ",G24.14)') tol
          write(*,'(" required absolute tolerance",T40," : ",G24.14)') t2
          write(*,*)
          error stop
        end if
      end do
    else if (vt == 3) then
! complex variables
      read(91,*,err=10) tol
      read(92,*,err=20) tol
      do j=1,nv
        read(91,*,err=10) k,a,b
        zv_=cmplx(a,b,8)
        if (j /= k) goto 10
        read(92,*,err=20) k,a,b
        zv=cmplx(a,b,8)
        if (j /= k) goto 20
        t1=abs(zv_-zv)
        t2=abs(zv_)*tol
        if ((t1 > t2).and.(abs(zv_) > 1.d-4)) then
          write(*,*)
          write(*,'("Error(testcheck): variable ",I8," outside tolerance")') j
          write(*,'(" for quantity ''",A,"''")') trim(descr)
          write(*,'(" ",A," (correct value)",T40," : ",2G24.14)') &
           trim(fname_),zv_
          write(*,'(" ",A,T40," : ",2G24.14)') trim(fname),zv
          write(*,'(" difference",T40," : ",G24.14)') t1
          write(*,'(" required relative tolerance",T40," : ",G24.14)') tol
          write(*,'(" required absolute tolerance",T40," : ",G24.14)') t2
          write(*,*)
          error stop
        end if
      end do
    else
      write(*,*)
      write(*,'("Error(testcheck): variable type not defined : ",I8)') vt
      write(*,*)
      error stop
    end if
    close(91)
    close(92)
    n=n+1
  end if
end do
if (n == 0) then
  write(*,*)
  write(*,'("Warning(testcheck): no tests found")')
else
  write(*,*)
  write(*,'("Info(testcheck): passed all tests")')
end if
return
10 continue
write(*,*)
write(*,'("Error(testcheck): error reading from ",A)') trim(fname_)
write(*,*)
error stop
20 continue
write(*,*)
write(*,'("Error(testcheck): error reading from ",A)') trim(fname)
write(*,*)
error stop
end subroutine