File: testcheck.f90

package info (click to toggle)
elkcode 5.4.24-2
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 12,840 kB
  • sloc: f90: 48,415; fortran: 22,457; perl: 965; makefile: 384; sh: 369; python: 105; ansic: 67
file content (158 lines) | stat: -rw-r--r-- 4,737 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

! 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(*,*)
      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_.ne.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(*,*)
      stop
    end if
    if (nv_.ne.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(*,*)
      stop
    end if
    if (nv.le.0) then
      write(*,*)
      write(*,'("Error(testcheck): nv <= 0 : ",I8)') nv
      write(*,*)
      stop
    end if
    if (vt.eq.1) then
! integer variables
      do j=1,nv
        read(91,*,err=10) k,iv_
        if (j.ne.k) goto 10
        read(92,*,err=20) k,iv
        if (j.ne.k) goto 20
        if (iv.ne.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(*,*)
          stop
        end if
      end do
    else if (vt.eq.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.ne.k) goto 10
        read(92,*,err=20) k,rv
        if (j.ne.k) goto 20
        t1=abs(rv_-rv)
        t2=abs(rv_)*tol
        if ((t1.gt.t2).and.(abs(rv_).gt.1.d-4)) then
          write(*,*)
          write(*,'("Error(testcheck): variable ",I8," outside tolerance")') j
          write(*,'(" for quantity ''",A,"''")') trim(descr)
          write(*,'(" ",A," (correct value)",T40," : ",G22.12)') trim(fname_), &
           rv_
          write(*,'(" ",A,T40," : ",G22.12)') trim(fname),rv
          write(*,'(" absolute difference",T40," : ",G22.12)') t1
          write(*,'(" required relative tolerance",T40," : ",G22.12)') tol
          write(*,'(" required absolute tolerance",T40," : ",G22.12)') t2
          write(*,*)
          stop
        end if
      end do
    else if (vt.eq.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.ne.k) goto 10
        read(92,*,err=20) k,a,b
        zv=cmplx(a,b,8)
        if (j.ne.k) goto 20
        t1=abs(zv_-zv)
        t2=abs(zv_)*tol
        if ((t1.gt.t2).and.(abs(zv_).gt.1.d-4)) then
          write(*,*)
          write(*,'("Error(testcheck): variable ",I8," outside tolerance")') j
          write(*,'(" for quantity ''",A,"''")') trim(descr)
          write(*,'(" ",A," (correct value)",T40," : ",2G22.12)') &
           trim(fname_),zv_
          write(*,'(" ",A,T40," : ",2G22.12)') trim(fname),zv
          write(*,'(" difference",T40," : ",G22.12)') t1
          write(*,'(" required relative tolerance",T40," : ",G22.12)') tol
          write(*,'(" required absolute tolerance",T40," : ",G22.12)') t2
          write(*,*)
          stop
        end if
      end do
    else
      write(*,*)
      write(*,'("Error(testcheck): variable type not defined : ",I8)') vt
      write(*,*)
      stop
    end if
    close(91)
    close(92)
    n=n+1
  end if
end do
if (n.eq.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(*,*)
stop
20 continue
write(*,*)
write(*,'("Error(testcheck): error reading from ",A)') trim(fname)
write(*,*)
stop
end subroutine