NCEPLIBS-bufr  12.3.0
borts.F90
Go to the documentation of this file.
1 
5 
14 recursive subroutine bort(str)
15 
16  use bufrlib
17 
18  use moda_borts
19 
20  implicit none
21 
22  character*(*), intent(in) :: str
23 
24  if (bort_catch == 'Y') then
25  call strsuc(str, caught_str, caught_str_len)
26  call bort_goto_target_c()
27  endif
28 
29  call errwrt(' ')
30  call errwrt('***********BUFR ARCHIVE LIBRARY ABORT**************')
31  call errwrt(str)
32  call errwrt('***********BUFR ARCHIVE LIBRARY ABORT**************')
33  call errwrt(' ')
34  stop 8
35 
36 end subroutine bort
37 
47 recursive subroutine bort2(str1,str2)
48 
49  use bufrlib
50 
51  use moda_borts
52 
53  implicit none
54 
55  character*(*), intent(in) :: str1, str2
56 
57  if (bort_catch == 'Y') then
58  call strsuc(str1, caught_str, caught_str_len)
59  caught_str = str1(1:caught_str_len) // str2
60  call strsuc(caught_str, caught_str, caught_str_len)
61  call bort_goto_target_c()
62  endif
63 
64  call errwrt(' ')
65  call errwrt('***********BUFR ARCHIVE LIBRARY ABORT**************')
66  call errwrt(str1)
67  call errwrt(str2)
68  call errwrt('***********BUFR ARCHIVE LIBRARY ABORT**************')
69  call errwrt(' ')
70  stop 8
71 
72 end subroutine bort2
73 
118 integer function catch_borts(cbc) result (iret)
119 
120  use modv_vars, only: iprt
121 
122  use moda_borts
123 
124  implicit none
125 
126  character, intent(in) :: cbc
127  character my_cbc
128 
129  iret = 0
130  my_cbc = cbc
131  call capit(my_cbc)
132  if (iprt >= 1) call errwrt('++++++++++++++++++WARNING+++++++++++++++++++')
133 
134  if (my_cbc == 'Y') then
135  bort_catch = my_cbc
136  bort_target_is_unset = .true.
137  if (iprt >= 1) call errwrt('BUFRLIB: CATCH_BORTS - ENABLING BORT CATCHING')
138  else if (my_cbc == 'N') then
139  bort_catch = my_cbc
140  bort_target_is_unset = .false.
141  if (iprt >= 1) call errwrt('BUFRLIB: CATCH_BORTS - DISABLING BORT CATCHING')
142  else
143  iret = -1
144  if (iprt >= 1) call errwrt('BUFRLIB: CATCH_BORTS - ILLEGAL INPUT VALUE; NO ACTION WAS TAKEN')
145  endif
146 
147  if (iprt >= 1) call errwrt('++++++++++++++++++WARNING+++++++++++++++++++')
148 
149  return
150 end function catch_borts
151 
159 integer function bort_target_set() result (iret)
160 
161  use moda_borts
162 
163  implicit none
164 
165  if (bort_target_is_unset) then
166  bort_target_is_unset = .false.
167  caught_str_len = 0
168  iret = 1
169  else
170  iret = 0
171  endif
172 
173  return
174 end function bort_target_set
175 
179 subroutine bort_target_unset
180 
181  use moda_borts
182 
183  implicit none
184 
185  if (bort_catch == 'Y') bort_target_is_unset = .true.
186 
187  return
188 end subroutine bort_target_unset
189 
203 recursive subroutine check_for_bort(bort_str, bort_str_len)
204 
205  use modv_vars, only: iprt, im8b
206 
207  use moda_borts
208 
209  implicit none
210 
211  character*(*), intent(out) :: bort_str
212 
213  integer, intent(out) :: bort_str_len
214 
215  ! Check for I8 integers
216  if(im8b) then
217  im8b = .false.
218  call check_for_bort(bort_str,bort_str_len)
219  call x48(bort_str_len,bort_str_len,1)
220  im8b = .true.
221  return
222  endif
223 
224  if (bort_catch == 'N') then
225  if (iprt >= 1) then
226  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
227  call errwrt('BUFRLIB: CHECK_FOR_BORT WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED CATCH_BORTS')
228  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
229  endif
230  bort_str_len = -1
231  else if (caught_str_len == 0) then
232  bort_str_len = 0
233  bort_str = ' '
234  else
235  bort_str_len = min(len(bort_str),caught_str_len)
236  bort_str = caught_str(1:bort_str_len)
237  endif
238 
239  return
240 end subroutine check_for_bort
check_for_bort
recursive subroutine check_for_bort(bort_str, bort_str_len)
Check whether a bort error occurred during a previous call to an NCEPLIBS-bufr subroutine or function...
Definition: borts.F90:204
bort
recursive subroutine bort(str)
Log an error message, then either return to or abort the application program.
Definition: borts.F90:15
catch_borts
integer function catch_borts(cbc)
Specify whether subsequent bort errors should be caught and returned to the application program.
Definition: borts.F90:119
bort_target_unset
subroutine bort_target_unset
Clear any existing bort target.
Definition: borts.F90:180
bort2
recursive subroutine bort2(str1, str2)
Log two error messages, then either return to or abort the application program.
Definition: borts.F90:48
bort_target_set
integer function bort_target_set()
Sets a new bort target, if bort catching is enabled and such a target doesn't already exist.
Definition: borts.F90:160
errwrt
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
bufrlib::bort_goto_target_c
Definition: bufrlib.F90:340
strsuc
subroutine strsuc(str1, str2, lens)
Remove leading and trailing blanks from a character string.
Definition: misc.F90:199
capit
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
Definition: misc.F90:334
bufrlib
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Definition: bufrlib.F90:11
moda_borts
Declare variables used to optionally catch and return any future bort error string to the application...
Definition: modules_arrs.F90:910
moda_borts::caught_str_len
integer caught_str_len
Length of bort error string.
Definition: modules_arrs.F90:923
moda_borts::bort_catch
character bort_catch
Flag indicating whether bort errors generated during all future calls to NCEPLIBS-bufr subroutines an...
Definition: modules_arrs.F90:916
moda_borts::caught_str
character *300 caught_str
Bort error string.
Definition: modules_arrs.F90:921
moda_borts::bort_target_is_unset
logical bort_target_is_unset
Set to .true.
Definition: modules_arrs.F90:919
x48
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x4884.F90:18