[207] | 1 | MODULE module_debug |
---|
| 2 | |
---|
| 3 | integer, parameter :: STDOUT=-1, DEBUG=0, INFORM=1, WARN=2, ERROR=3 |
---|
| 4 | |
---|
| 5 | CONTAINS |
---|
| 6 | |
---|
| 7 | SUBROUTINE mprintf(assertion, level, fmtstring, i1, i2, i3, f1, f2, f3, s1, s2, s3) |
---|
| 8 | |
---|
| 9 | implicit none |
---|
| 10 | |
---|
| 11 | ! Arguments |
---|
| 12 | integer, intent(in) :: level |
---|
| 13 | logical, intent(in) :: assertion |
---|
| 14 | character (len=*), intent(in) :: fmtstring |
---|
| 15 | integer, intent(in), optional :: i1, i2, i3 |
---|
| 16 | real, intent(in), optional :: f1, f2, f3 |
---|
| 17 | character (len=*), intent(in), optional :: s1, s2, s3 |
---|
| 18 | |
---|
| 19 | ! Local variables |
---|
| 20 | integer :: idxi, idxf, idxs, istart, i, iend, ia |
---|
| 21 | real :: fa |
---|
| 22 | character (len=128) :: sa |
---|
| 23 | |
---|
| 24 | idxi = 1 |
---|
| 25 | idxf = 1 |
---|
| 26 | idxs = 1 |
---|
| 27 | istart = 1 |
---|
| 28 | iend = len_trim(fmtstring) |
---|
| 29 | |
---|
| 30 | IF (assertion) THEN |
---|
| 31 | |
---|
| 32 | IF (level == DEBUG) THEN |
---|
| 33 | WRITE(6,'(a)',advance='no') 'DEBUG: ' |
---|
| 34 | ELSE IF (level == INFORM) THEN |
---|
| 35 | WRITE(6,'(a)',advance='no') 'INFORM: ' |
---|
| 36 | ELSE IF (level == WARN) THEN |
---|
| 37 | WRITE(6,'(a)',advance='no') 'WARNING: ' |
---|
| 38 | ELSE IF (level == ERROR) THEN |
---|
| 39 | WRITE(6,'(a)',advance='no') 'ERROR: ' |
---|
| 40 | END IF |
---|
| 41 | |
---|
| 42 | i = index(fmtstring(istart:iend),'%') |
---|
| 43 | DO WHILE (i > 0 .and. i < iend) |
---|
| 44 | i = i + istart - 1 |
---|
| 45 | WRITE(6,'(a)',advance='no') fmtstring(istart:i-1) |
---|
| 46 | |
---|
| 47 | IF (fmtstring(i+1:i+1) == '%') THEN |
---|
| 48 | WRITE(6,'(a1)',advance='no') '%' |
---|
| 49 | |
---|
| 50 | ELSE IF (fmtstring(i+1:i+1) == 'i') THEN |
---|
| 51 | IF (idxi == 1 .and. present(i1)) THEN |
---|
| 52 | ia = i1 |
---|
| 53 | ELSE IF (idxi == 2 .and. present(i2)) THEN |
---|
| 54 | ia = i2 |
---|
| 55 | ELSE IF (idxi == 3 .and. present(i3)) THEN |
---|
| 56 | ia = i3 |
---|
| 57 | END IF |
---|
| 58 | |
---|
| 59 | IF (ia < 10) THEN |
---|
| 60 | WRITE(6,'(i1)',advance='no') ia |
---|
| 61 | ELSE IF (ia < 100) THEN |
---|
| 62 | WRITE(6,'(i2)',advance='no') ia |
---|
| 63 | ELSE IF (ia < 1000) THEN |
---|
| 64 | WRITE(6,'(i3)',advance='no') ia |
---|
| 65 | ELSE IF (ia < 10000) THEN |
---|
| 66 | WRITE(6,'(i4)',advance='no') ia |
---|
| 67 | ELSE IF (ia < 100000) THEN |
---|
| 68 | WRITE(6,'(i5)',advance='no') ia |
---|
| 69 | ELSE |
---|
| 70 | WRITE(6,'(i9)',advance='no') ia |
---|
| 71 | END IF |
---|
| 72 | idxi = idxi + 1 |
---|
| 73 | |
---|
| 74 | ELSE IF (fmtstring(i+1:i+1) == 'f') THEN |
---|
| 75 | IF (idxf == 1 .and. present(f1)) THEN |
---|
| 76 | fa = f1 |
---|
| 77 | ELSE IF (idxf == 2 .and. present(f2)) THEN |
---|
| 78 | fa = f2 |
---|
| 79 | ELSE IF (idxf == 3 .and. present(f3)) THEN |
---|
| 80 | fa = f3 |
---|
| 81 | END IF |
---|
| 82 | |
---|
| 83 | IF (fa < -100000.) THEN |
---|
| 84 | WRITE(6,'(f12.4)',advance='no') fa |
---|
| 85 | ELSE IF (fa < -10000.) THEN |
---|
| 86 | WRITE(6,'(f11.4)',advance='no') fa |
---|
| 87 | ELSE IF (fa < -1000.) THEN |
---|
| 88 | WRITE(6,'(f10.4)',advance='no') fa |
---|
| 89 | ELSE IF (fa < -100.) THEN |
---|
| 90 | WRITE(6,'(f9.4)',advance='no') fa |
---|
| 91 | ELSE IF (fa < -10.) THEN |
---|
| 92 | WRITE(6,'(f8.4)',advance='no') fa |
---|
| 93 | ELSE IF (fa < 0.) THEN |
---|
| 94 | WRITE(6,'(f7.4)',advance='no') fa |
---|
| 95 | ELSE IF (fa < 10.) THEN |
---|
| 96 | WRITE(6,'(f6.4)',advance='no') fa |
---|
| 97 | ELSE IF (fa < 100.) THEN |
---|
| 98 | WRITE(6,'(f7.4)',advance='no') fa |
---|
| 99 | ELSE IF (fa < 1000.) THEN |
---|
| 100 | WRITE(6,'(f8.4)',advance='no') fa |
---|
| 101 | ELSE IF (fa < 10000.) THEN |
---|
| 102 | WRITE(6,'(f9.4)',advance='no') fa |
---|
| 103 | ELSE IF (fa < 100000.) THEN |
---|
| 104 | WRITE(6,'(f10.4)',advance='no') fa |
---|
| 105 | ELSE |
---|
| 106 | WRITE(6,'(f15.4)',advance='no') fa |
---|
| 107 | END IF |
---|
| 108 | idxf = idxf + 1 |
---|
| 109 | |
---|
| 110 | ELSE IF (fmtstring(i+1:i+1) == 's') THEN |
---|
| 111 | IF (idxs == 1 .and. present(s1)) THEN |
---|
| 112 | sa = s1 |
---|
| 113 | ELSE IF (idxs == 2 .and. present(s2)) THEN |
---|
| 114 | sa = s2 |
---|
| 115 | ELSE IF (idxs == 3 .and. present(s3)) THEN |
---|
| 116 | sa = s3 |
---|
| 117 | END IF |
---|
| 118 | |
---|
| 119 | WRITE(6,'(a)',advance='no') trim(sa) |
---|
| 120 | idxs = idxs + 1 |
---|
| 121 | |
---|
| 122 | END IF |
---|
| 123 | |
---|
| 124 | istart = i+2 |
---|
| 125 | i = index(fmtstring(istart:iend),'%') |
---|
| 126 | END do |
---|
| 127 | |
---|
| 128 | WRITE(6,'(a)') fmtstring(istart:iend) |
---|
| 129 | |
---|
| 130 | IF (level == ERROR) stop |
---|
| 131 | |
---|
| 132 | END IF |
---|
| 133 | |
---|
| 134 | |
---|
| 135 | END SUBROUTINE mprintf |
---|
| 136 | |
---|
| 137 | END MODULE module_debug |
---|