source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/mct/mpeu/m_die.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 4 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from ​https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818
File size: 12.1 KB
Line 
1!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
3!-----------------------------------------------------------------------
4! CVS m_die.F90,v 1.4 2004-04-21 22:54:47 jacob Exp
5! CVS MCT_2_8_0 
6!-----------------------------------------------------------------------
7!BOP
8!
9! !MODULE: m_die - die with mpout flushed
10!
11! !DESCRIPTION:
12!
13! !INTERFACE:
14
15    module m_die
16      use m_mpif90, only : MP_perr
17      implicit none
18      private   ! except
19
20      public :: die             ! signal an exception
21      public :: diex            ! a special die() supporting macros
22      public :: perr,warn       ! message(s) to stderr
23      public :: perr_die        ! to be phased out
24      public :: MP_die          ! a special die() for MPI errors
25      public :: MP_perr         ! perr for MPI errors, from m_mpif90
26      public :: MP_perr_die     ! a special die() for MPI errors
27      public :: assert_         ! used by ASSERT() macro of assert.H
28
29      interface die; module procedure   &
30        die0_,  & ! die(where)
31        die1_,  & ! die(where,message)
32        die2_,  & ! die(where,proc,ier)
33        die4_     ! die(where,mesg1,ival1,mesg2,ival2)
34      end interface
35
36      interface diex; module procedure  &
37        diex_     ! diex(where,filename,lineno)
38      end interface
39
40      interface perr; module procedure  &
41        perr1_, & ! perr(where,message)
42        perr2_, & ! perr(where,proc,ier)
43        perr4_    ! perr(where,mesg1,ival1,mesg2,ival2)
44      end interface
45      interface warn; module procedure  &
46        perr1_, & ! perr(where,message)
47        perr2_, & ! perr(where,proc,ier)
48        perr4_    ! perr(where,mesg1,ival1,mesg2,ival2)
49      end interface
50
51      interface perr_die; module procedure      &
52        die2_     ! perr_die(where,proc,ier)
53      end interface
54
55      interface MP_die; module procedure        &
56        MPdie2_   ! MP_die(where,proc,ier)
57      end interface
58      interface MP_perr_die; module procedure   &
59        MPdie2_   ! MP_die(where,proc,ier)
60      end interface
61
62
63! !REVISION HISTORY:
64!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
65!EOP
66!_______________________________________________________________________
67  character(len=*),parameter :: myname='MCT(MPEU)::m_die'
68contains
69!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
71!-----------------------------------------------------------------------
72!BOP
73!
74! !IROUTINE: die0_ - flush(mpout) before die()
75!
76! !DESCRIPTION:
77!
78! !INTERFACE:
79
80    subroutine die0_(where)
81      use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison
82      use m_flow, only : flow_flush
83      use m_dropdead, only : ddie => die
84      implicit none
85      character(len=*),intent(in) :: where
86
87! !REVISION HISTORY:
88!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
89!EOP
90!_______________________________________________________________________
91  character(len=*),parameter :: myname_=myname//'::die0_'
92
93  call mpout_flush()
94  if(mpout_ison()) call flow_flush(mpout)
95  call mpout_close()
96  call ddie(where)
97
98end subroutine die0_
99
100!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
101!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
102!-----------------------------------------------------------------------
103!BOP
104!
105! !IROUTINE: die1_ - flush(mpout) before die()
106!
107! !DESCRIPTION:
108!
109! !INTERFACE:
110
111    subroutine die1_(where,message)
112      use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison
113      use m_flow, only : flow_flush
114      use m_dropdead, only : ddie => die
115      implicit none
116      character(len=*),intent(in) :: where
117      character(len=*),intent(in) :: message
118
119! !REVISION HISTORY:
120!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
121!EOP
122!_______________________________________________________________________
123  character(len=*),parameter :: myname_=myname//'::die1_'
124
125  call mpout_flush()
126  if(mpout_ison()) call flow_flush(mpout)
127  call mpout_close()
128
129  call perr1_(where,message)
130  call ddie(where)
131
132end subroutine die1_
133
134!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
136!-----------------------------------------------------------------------
137!BOP
138!
139! !IROUTINE: die2_ - flush(mpout) before die()
140!
141! !DESCRIPTION:
142!
143! !INTERFACE:
144
145    subroutine die2_(where,proc,ier)
146      use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison
147      use m_flow, only : flow_flush
148      use m_dropdead, only : ddie => die
149      implicit none
150      character(len=*),intent(in) :: where
151      character(len=*),intent(in) :: proc
152      integer,intent(in) :: ier
153
154! !REVISION HISTORY:
155!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
156!EOP
157!_______________________________________________________________________
158  character(len=*),parameter :: myname_=myname//'::die2_'
159
160  call mpout_flush()
161  if(mpout_ison()) call flow_flush(mpout)
162  call mpout_close()
163
164  call perr2_(where,proc,ier)
165  call ddie(where)
166
167end subroutine die2_
168
169!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
170!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
171!-----------------------------------------------------------------------
172!BOP
173!
174! !IROUTINE: die4_ - flush(mpout) before die()
175!
176! !DESCRIPTION:
177!
178! !INTERFACE:
179
180    subroutine die4_(where,mesg1,ival1,mesg2,ival2)
181      use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison
182      use m_flow, only : flow_flush
183      use m_dropdead, only : ddie => die
184      implicit none
185      character(len=*),intent(in) :: where
186      character(len=*),intent(in) :: mesg1
187      integer,intent(in) :: ival1
188      character(len=*),intent(in) :: mesg2
189      integer,intent(in) :: ival2
190
191! !REVISION HISTORY:
192!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
193!EOP
194!_______________________________________________________________________
195  character(len=*),parameter :: myname_=myname//'::die4_'
196
197  call mpout_flush()
198  if(mpout_ison()) call flow_flush(mpout)
199  call mpout_close()
200
201  call perr4_(where,mesg1,ival1,mesg2,ival2)
202  call ddie(where)
203
204end subroutine die4_
205
206!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
207!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
208!-----------------------------------------------------------------------
209!BOP
210!
211! !IROUTINE: diex_ - flush(mpout) before die()
212!
213! !DESCRIPTION:
214!
215! !INTERFACE:
216
217    subroutine diex_(where,filename,line)
218      use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison
219      use m_flow, only : flow_flush
220      use m_dropdead, only : ddie => die
221      implicit none
222      character(len=*),intent(in) :: where
223      character(len=*),intent(in) :: filename
224      integer,intent(in) :: line
225
226! !REVISION HISTORY:
227!       26Feb98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
228!EOP
229!_______________________________________________________________________
230  character(len=*),parameter :: myname_=myname//'::diex_'
231
232  call mpout_flush()
233  if(mpout_ison()) call flow_flush(mpout)
234  call mpout_close()
235  call ddie(where,filename,line)
236
237end subroutine diex_
238
239!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
240!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
241!BOP -------------------------------------------------------------------
242!
243! !IROUTINE: perr1_ - send a simple error message to _stderr_
244!
245! !DESCRIPTION:
246!
247! !INTERFACE:
248
249    subroutine perr1_(where,message)
250      use m_stdio,only : stderr
251      implicit none
252      character(len=*),intent(in) :: where
253      character(len=*),intent(in) :: message
254
255! !REVISION HISTORY:
256!       27Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
257!EOP ___________________________________________________________________
258
259  character(len=*),parameter :: myname_=myname//'::perr1_'
260
261  write(stderr,'(3a)') where,': ',message
262
263end subroutine perr1_
264
265!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
267!BOP -------------------------------------------------------------------
268!
269! !IROUTINE: perr2_ - send a simple error message to _stderr_
270!
271! !DESCRIPTION:
272!
273! !INTERFACE:
274
275    subroutine perr2_(where,proc,ier)
276      use m_stdio,only : stderr
277      implicit none
278      character(len=*),intent(in) :: where
279      character(len=*),intent(in) :: proc
280      integer,intent(in) :: ier
281
282! !REVISION HISTORY:
283!       27Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
284!EOP ___________________________________________________________________
285
286  character(len=*),parameter :: myname_=myname//'::perr2_'
287  character(len=16) :: cer
288  integer :: ios
289
290  cer='*******'
291  write(cer,'(i16)',iostat=ios) ier
292  write(stderr,'(5a)') where,': ',      &
293        proc,' error, stat =',trim(adjustl(cer))
294
295end subroutine perr2_
296
297!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
298!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
299!BOP -------------------------------------------------------------------
300!
301! !IROUTINE: perr4_ - send a simple error message to _stderr_
302!
303! !DESCRIPTION:
304!
305! !INTERFACE:
306
307    subroutine perr4_(where,mesg1,ival1,mesg2,ival2)
308      use m_stdio,only : stderr
309      implicit none
310      character(len=*),intent(in) :: where
311      character(len=*),intent(in) :: mesg1
312      integer,intent(in) :: ival1
313      character(len=*),intent(in) :: mesg2
314      integer,intent(in) :: ival2
315
316! !REVISION HISTORY:
317!       27Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
318!EOP ___________________________________________________________________
319
320  character(len=*),parameter :: myname_=myname//'::perr4_'
321  character(len=16) :: cval1,cval2
322  integer :: ios
323
324  cval1='*******'
325  cval2='*******'
326  write(cval1,'(i16)',iostat=ios) ival1
327  write(cval2,'(i16)',iostat=ios) ival2
328
329  write(stderr,'(10a)') where,': error, ',      &
330        mesg1,'=',trim(adjustl(cval1)),', ',    &
331        mesg2,'=',trim(adjustl(cval2)),'.'
332
333end subroutine perr4_
334
335!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
336!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
337!BOP -------------------------------------------------------------------
338!
339! !IROUTINE: MPdie2_ - invoke MP_perr before die_
340!
341! !DESCRIPTION:
342!
343! !INTERFACE:
344
345    subroutine MPdie2_(where,proc,ier)
346      use m_mpif90, only : MP_perr
347      implicit none
348      character(len=*),intent(in) :: where
349      character(len=*),intent(in) :: proc
350      integer,intent(in) :: ier
351
352! !REVISION HISTORY:
353!       27Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
354!EOP ___________________________________________________________________
355
356  character(len=*),parameter :: myname_=myname//'::MPdie2_'
357
358  call MP_perr(where,proc,ier)
359  call die0_(where)
360
361end subroutine MPdie2_
362!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
364!BOP -------------------------------------------------------------------
365!
366! !IROUTINE: assert_ - an utility called by ASSERT() macro only
367!
368! !DESCRIPTION:
369!
370! !INTERFACE:
371
372    subroutine assert_(str, file, line)
373      use m_mpout,only : mpout,mpout_flush,mpout_close,mpout_ison
374      use m_flow,only : flow_flush
375      use m_dropdead,only : ddie => die
376      implicit none
377      Character(Len=*), Intent(In) :: str       ! a message
378      Character(Len=*), Intent(In) :: file      ! a filename
379      Integer, Intent(In) :: line               ! a line number
380
381! !REVISION HISTORY:
382!       25Aug00 - Jing Guo <guo@dao.gsfc.nasa.gov>
383!               - modified
384!               - included into m_die for easier module management
385!       before  - Tom Clune
386!               - Created for MPI PSAS implementation as a separate
387!                 module
388!       19Jan01 - J. Larson <larson@mcs.anl.gov> - removed nested
389!                 single/double/single quotes in the second argument
390!                 to the call to perr1_().  This was done for the pgf90
391!                 port.
392!EOP ___________________________________________________________________
393
394  character(len=*),parameter :: myname_='ASSERT_'
395
396  call mpout_flush()
397  if(mpout_ison()) call flow_flush(mpout)
398  call mpout_close()
399
400  call perr1_(myname_,'failed: "//str//")')
401  call ddie(myname_,file,line)
402
403End subroutine assert_
404end module m_die
Note: See TracBrowser for help on using the repository browser.