Statistics
| Branch: | Revision:

root / synthbench / euroben-dm / mod2f / .svn / text-base / errchk.f.svn-base @ 0:839f52ef7657

History | View | Annotate | Download (5.5 kB)

1
      Subroutine errchk( a, b, m, n, err, jerr )
2
! ----------------------------------------------------------------------
3
! --- ERRCHK checks the errors made in the transformation of a
4
!     complex-to-complex FFT. ERRCHK is specific for the input
5
!     as produced in program 'mod2f' (distributed memory version).
6
!     The Real part is a full cycle of a cosine signal and the
7
!     Imaginary part is 0.0 everywhere.
8
!     The resulting transform should show values of float(N*M*NODES/2) 
9
!     for A(1,2) on node 1 and A(M,N) on node NODES. All other entries
10
!     should be 0.0D0. This is checked below with a Floating-Point
11
!     error margin of ERR = ( 10*N Log N )*EPS, with EPS the
12
!     Floating-Point spacing of the machine tested.
13
!
14
! --- The Real part of A is stored in A(1,1), ..., A(M,N);
15
!     the Imaginary part in B(1,1), ..., B(M,N).
16
!
17
! --- The elements that not meet the error criterion are normally
18
!     NOT printed. However, by decommenting the appropriate lines
19
!     all offending entries are printed. When the error criterion 
20
!     is exceeded by an element of A and/or B, the output parameter
21
!     IERR is increased by 1, So, after completion the total number
22
!     of errors is available in IERR.
23
! ----------------------------------------------------------------------
24
      Use              mpi_module
25
      Use              numerics
26

    
27
      Integer       :: m, n, jerr
28
      Real(l_)      :: a(m,n), b(m,n), err
29

    
30
      Integer       :: all_err, datype, i, j, l_err, mbase, ntst
31
! ----------------------------------------------------------------------
32
      jerr = 0
33
      ntst = n*m*nodes
34
! ----------------------------------------------------------------------
35
! --- First check Imaginary elements (All these should be about 0.0D0).
36

    
37
      mbase = me*m*n
38
      Do j = 1, n
39
         Do i = 1, m
40
            If ( Abs( b(i,j) ) > err ) Then
41
!              Print 1040, ntst , mbase + ( i - 1)*n + j, 
42
!    &                     b(i,j), err
43
               jerr = jerr + 1
44
            End If
45
         End Do
46
      End Do
47
! ----------------------------------------------------------------------
48
! --- Check Real elements that are not in the first and last node.
49
!     (All these should be about 0.0).
50

    
51
      If ( me /= 0 .AND. me /= nodes - 1 ) Then
52
         Do j = 1, n
53
            Do i = 1, m
54
               If ( Abs( a(i,j) ) > err ) Then
55
!                 Print 1010, ntst , mbase + ( i - 1)*n + j, 
56
!    &                        a(i,j), err
57
                  jerr = jerr + 1
58
               End If
59
            End Do
60
         End Do            
61
      End If
62
! ----------------------------------------------------------------------
63
! --- Check Real elements in first node: A(1,2) should be about
64
!     float( N*M*NODES/2 ).
65

    
66
      If ( me == 0 ) Then
67
         Do i = 1, m
68
            If ( Abs( a(i,1) ) > err ) Then
69
!              Print 1010, ntst , ( i - 1)*n + 1, 
70
!    &                     a(i,1), err
71
               jerr = jerr + 1
72
            End If
73
         End Do
74
         Do i = 2, m
75
            If ( Abs( a(i,2) ) > err ) Then
76
!              Print 1010, ntst , ( i - 1)*n + 1, 
77
!    &                     a(i,2), err
78
               jerr = jerr + 1
79
            End If
80
         End Do
81
         Do j = 3, n
82
            Do i = 1, m
83
               If ( Abs( a(i,j) ) > err .AND. nodes /= 1 ) Then
84
!                 Print 1010, ntst , ( i - 1)*n + j, 
85
!    &                        a(i,j), err
86
                  jerr = jerr + 1
87
               End If
88
            End Do
89
         End Do
90
         If ( Abs( a(1,2) - ntst/2.0_l_ ) > err ) Then
91
!           Print 1020, ntst, a(1,2), ntst/2.0_l_
92
            jerr = jerr + 1
93
         End If
94
      End If
95
! ----------------------------------------------------------------------
96
! --- Check Real elements in last node: A(M,N) should be about
97
!     float( N*M*NODES/2 ), all others 0.0.
98
!
99
      If ( me == (nodes - 1) ) Then
100
         Do j = 1, n - 1
101
            Do i = 1, m
102
               If ( Abs( a(i,j) ) > err .AND. nodes /= 1 ) Then
103
!                 Print 1010, ntst , mbase + ( i - 1)*n + j, 
104
!    &                        a(i,j), err
105
                  jerr = jerr + 1
106
               End If
107
            End Do
108
         End Do
109
         Do i = 1, m-1
110
            If ( Abs( a(i,n) ) > err ) Then
111
!              Print 1010, ntst , mbase + ( i - 1)*n + j, 
112
!    &                     a(i,n), err
113
               jerr = jerr + 1
114
            End If
115
         End Do        
116
         If ( Abs( a(m,n) - ntst/2.0_l_ ) > err ) Then
117
!           Print 1030, ntst, a(m,n), ntst/2.0_l_
118
            jerr = jerr + 1
119
         End If
120
      End If
121
! ----------------------------------------------------------------------
122
! --- Collect the OK values on the first node.     
123

    
124
      datype = MPI_Integer
125
      Call MPI_Reduce( jerr, all_err, 1, datype, MPI_Sum, 0,
126
     &                 MPI_Comm_World, l_err )
127
      If ( me == 0 ) jerr = all_err
128
! ----------------------------------------------------------------------
129
 1010 Format( 'Real element, Transform length = ', I7, 
130
     &        ' Element no. = ', I7, ' Value = ', 1Pg11.3,
131
     &        ' Should be <= ', 1Pg11.3 )
132
 1020 Format( 'Second Real element, Transform length = ', I7, 
133
     &        ' Value = ', 1Pg11.3, ' Should be ', 1Pg11.3 )
134
 1030 Format( 'N-th Real element, Transform length = ', I7,
135
     &        ' Value = ', 1Pg11.3, ' Should be ', 1Pg11.3 ) 
136
 1040 Format( 'Imaginary element, Transform length = ', I7,
137
     &        ' Element no. = ', I7, ' Value = ', 1Pg11.3,
138
     &        ' Should be <= ', 1Pg11.3 )
139
! ----------------------------------------------------------------------
140
      End Subroutine errchk