source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/psmile/src/mod_oasis_sys.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 5 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: 7.0 KB
Line 
1MODULE mod_oasis_sys
2
3   USE mod_oasis_kinds
4   USE mod_oasis_data
5
6   IMPLICIT NONE
7
8   private
9
10   public oasis_abort_noarg
11   public oasis_abort
12   public oasis_flush
13   public oasis_unitsetmin
14   public oasis_unitget
15   public oasis_unitfree
16   public oasis_debug_enter
17   public oasis_debug_exit
18   public oasis_debug_note
19
20   integer(ip_intwp_p),parameter :: muni = 20
21   integer(ip_intwp_p),save :: unitno(muni) = -1
22   integer(ip_intwp_p),save :: maxion
23   integer(ip_intwp_p),parameter :: tree_delta = 2
24   integer(ip_intwp_p),save :: tree_indent = 0
25
26!--------------------------------------------------------------------
27CONTAINS
28!--------------------------------------------------------------------
29
30   SUBROUTINE oasis_abort_noarg()
31
32   IMPLICIT NONE
33
34!--------------------------------------------------------------------
35   INTEGER                      :: ierror
36   character(len=*),parameter   :: subname = 'oasis_abort_noarg'
37!--------------------------------------------------------------------
38
39#if defined use_comm_MPI1 || defined use_comm_MPI2
40   CALL MPI_ABORT (mpi_comm_global, 0, ierror)
41#endif
42
43   STOP
44
45 END SUBROUTINE oasis_abort_noarg
46
47!--------------------------------------------------------------------
48
49   SUBROUTINE oasis_abort(id_compid, cd_routine, cd_message)
50
51   IMPLICIT NONE
52!--------------------------------------------------------------------
53   INTEGER(kind=ip_intwp_p),INTENT(in) :: id_compid
54   CHARACTER(len=*), INTENT(in) :: cd_routine
55   CHARACTER(len=*), INTENT(in) :: cd_message
56!--------------------------------------------------------------------
57   INTEGER                      :: ierror
58   character(len=*),parameter   :: subname = 'oasis_abort'
59!--------------------------------------------------------------------
60
61   WRITE (nulprt,'(a)') subname//' from '//TRIM(cd_routine)
62   WRITE (nulprt,'(a)') subname//' error = '//TRIM(cd_message)
63
64#if defined use_comm_MPI1 || defined use_comm_MPI2
65   CALL MPI_ABORT (mpi_comm_global, 0, ierror)
66#endif
67
68   STOP
69
70 END SUBROUTINE oasis_abort
71
72!==========================================================================
73   SUBROUTINE oasis_flush(nu)
74
75   IMPLICIT NONE
76
77!--------------------------------------------------------------------
78   INTEGER(kind=ip_intwp_p),INTENT(in) :: nu
79!--------------------------------------------------------------------
80   character(len=*),parameter :: subname = 'oasis_flush'
81!--------------------------------------------------------------------
82
83   CALL FLUSH(nu)
84
85 END SUBROUTINE oasis_flush
86
87!==========================================================================
88   SUBROUTINE oasis_unitget(uio)
89
90   IMPLICIT NONE
91
92!--------------------------------------------------------------------
93   INTEGER(kind=ip_intwp_p),INTENT(out) :: uio
94!--------------------------------------------------------------------
95   INTEGER(kind=ip_intwp_p) :: n1
96   logical :: found
97   character(len=*),parameter :: subname = 'oasis_unitget'
98!--------------------------------------------------------------------
99
100   n1 = 0
101   found = .false.
102   do while (n1 < muni .and. .not.found)
103      n1 = n1 + 1
104      if (unitno(n1) < 0) then
105         found = .true.
106         uio = n1 + maxion
107         unitno(n1) = uio
108         if (OASIS_debug >= 2) write(nulprt,*) subname,n1,uio
109      endif
110   enddo
111
112   if (.not.found) then
113      write(nulprt,*) subname,' ERROR no unitno available '
114      WRITE(nulprt,*) subname,' abort by model ',compid,' proc :',mpi_rank_local
115      CALL oasis_flush(nulprt)
116      call oasis_abort_noarg()
117   endif
118     
119 END SUBROUTINE oasis_unitget
120
121!==========================================================================
122   SUBROUTINE oasis_unitsetmin(uio)
123
124   IMPLICIT NONE
125
126!--------------------------------------------------------------------
127   INTEGER(kind=ip_intwp_p),INTENT(in) :: uio
128!--------------------------------------------------------------------
129   character(len=*),parameter :: subname = 'oasis_unitsetmin'
130!--------------------------------------------------------------------
131
132   maxion = uio
133   if (OASIS_debug >= 20) write(nulprt,*) subname,maxion
134     
135 END SUBROUTINE oasis_unitsetmin
136
137!==========================================================================
138   SUBROUTINE oasis_unitfree(uio)
139
140   IMPLICIT NONE
141
142!--------------------------------------------------------------------
143   INTEGER(kind=ip_intwp_p),INTENT(in) :: uio
144!--------------------------------------------------------------------
145   INTEGER(kind=ip_intwp_p) :: n1
146   character(len=*),parameter :: subname = 'oasis_unitfree'
147!--------------------------------------------------------------------
148
149   do n1 = 1,muni
150      if (unitno(n1) == uio) then
151         unitno(n1) = -1
152         if (OASIS_debug >= 20) write(nulprt,*) subname,n1,uio
153      endif
154   enddo
155
156 END SUBROUTINE oasis_unitfree
157
158!=========================================================================
159!==========================================================================
160SUBROUTINE oasis_debug_enter(string)
161
162   IMPLICIT NONE
163
164!--------------------------------------------------------------------
165   CHARACTER(len=*), INTENT(in) :: string
166   character(len=*),parameter :: subname = 'oasis_debug_enter'
167   CHARACTER(len=1), pointer :: ch_blank(:)
168   CHARACTER(len=500) :: tree_enter
169
170   if (OASIS_debug >= 10) then
171       ALLOCATE (ch_blank(tree_indent))
172       ch_blank='-'
173       tree_enter='**** ENTER '//TRIM(string)
174       WRITE(nulprt,*) ch_blank,TRIM(tree_enter)
175       tree_indent = tree_indent + tree_delta
176       DEALLOCATE (ch_blank)
177       CALL oasis_flush(nulprt)
178   endif
179
180 END SUBROUTINE oasis_debug_enter
181
182!==========================================================================
183SUBROUTINE oasis_debug_exit(string)
184
185   IMPLICIT NONE
186
187!--------------------------------------------------------------------
188   CHARACTER(len=*), INTENT(in) :: string
189   character(len=*),parameter :: subname = 'oasis_debug_exit'
190   CHARACTER(len=1), pointer :: ch_blank(:)
191   CHARACTER(len=500)        :: tree_exit
192
193   IF (OASIS_debug >= 10) THEN
194       tree_indent = MAX(0,tree_indent - tree_delta)
195       ALLOCATE (ch_blank(tree_indent))
196       ch_blank='-'
197       tree_exit='**** EXIT  '//TRIM(string)
198       WRITE(nulprt,*) ch_blank,TRIM(tree_exit)
199       DEALLOCATE (ch_blank)
200       CALL oasis_flush(nulprt)
201   ENDIF
202
203 END SUBROUTINE oasis_debug_exit
204
205!==========================================================================
206SUBROUTINE oasis_debug_note(string)
207
208   IMPLICIT NONE
209
210!--------------------------------------------------------------------
211   CHARACTER(len=*), INTENT(in) :: string
212   character(len=*),parameter :: subname = 'oasis_debug_note'
213   CHARACTER(len=1), pointer :: ch_blank(:)
214   CHARACTER(len=500) :: tree_note
215
216   if (OASIS_debug >= 12) then
217       ALLOCATE (ch_blank(tree_indent))
218       ch_blank='-'
219       tree_note='**** NOTE '//TRIM(string)
220       WRITE(nulprt,*) ch_blank,TRIM(tree_note)
221      DEALLOCATE(ch_blank)
222      call oasis_flush(nulprt)
223   endif
224
225 END SUBROUTINE oasis_debug_note
226
227!==========================================================================
228
229END MODULE mod_oasis_sys
Note: See TracBrowser for help on using the repository browser.