Actual source code: petscsysmod.F90
1: module petscmpi
2: #include <petscconf.h>
3: #include "petsc/finclude/petscsys.h"
4: #if defined(PETSC_HAVE_MPIUNI)
5: use mpiuni
6: #else
7: #if defined(PETSC_HAVE_MPI_F90MODULE)
8: use mpi
9: #else
10: #include "mpif.h"
11: #endif
12: #endif
14: public:: MPIU_REAL, MPIU_SUM, MPIU_SCALAR, MPIU_INTEGER
15: public:: PETSC_COMM_WORLD, PETSC_COMM_SELF
17: ! ----------------------------------------------------------------------------
18: ! BEGIN PETSc aliases for MPI_ constants
19: !
20: ! These values for __float128 are handled in the common block (below)
21: ! and transmitted from the C code
22: !
23: integer4 :: MPIU_REAL
24: integer4 :: MPIU_SUM
25: integer4 :: MPIU_SCALAR
26: integer4 :: MPIU_INTEGER
28: MPI_Comm::PETSC_COMM_WORLD=0
29: MPI_Comm::PETSC_COMM_SELF=0
31: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
32: !DEC$ ATTRIBUTES DLLEXPORT::MPIU_REAL
33: !DEC$ ATTRIBUTES DLLEXPORT::MPIU_SUM
34: !DEC$ ATTRIBUTES DLLEXPORT::MPIU_SCALAR
35: !DEC$ ATTRIBUTES DLLEXPORT::MPIU_INTEGER
36: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_COMM_SELF
37: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_COMM_WORLD
38: #endif
39: end module
41: module petscsysdefdummy
42: #if defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
43: use petscmpi
44: #else
45: use petscmpi, only: MPIU_REAL,MPIU_SUM,MPIU_SCALAR,MPIU_INTEGER,PETSC_COMM_WORLD,PETSC_COMM_SELF
46: #endif
47: #include <../src/sys/f90-mod/petscsys.h>
48: #include <../src/sys/f90-mod/petscdraw.h>
49: #include <../src/sys/f90-mod/petscviewer.h>
50: #include <../src/sys/f90-mod/petscviewer.h90>
51: #include <../src/sys/f90-mod/petscbag.h>
52: #include <../src/sys/f90-mod/petscerror.h>
53: #include <../src/sys/f90-mod/petsclog.h>
54: end module petscsysdefdummy
56: module petscsysdef
57: use petscsysdefdummy
59: ! These will eventually be automatically generated
60: interface operator(.ne.)
61: function petscviewernotequal(A,B)
62: import tPetscViewer
63: logical petscviewernotequal
64: type(tPetscViewer), intent(in) :: A,B
65: end function
66: end interface operator (.ne.)
67: interface operator(.eq.)
68: function petscviewerequals(A,B)
69: import tPetscViewer
70: logical petscviewerequals
71: type(tPetscViewer), intent(in) :: A,B
72: end function
73: end interface operator (.eq.)
75: interface operator(.ne.)
76: function petscdrawnotequal(A,B)
77: import tPetscDraw
78: logical petscdrawnotequal
79: type(tPetscDraw), intent(in) :: A,B
80: end function
81: end interface operator (.ne.)
82: interface operator(.eq.)
83: function petscdrawequals(A,B)
84: import tPetscDraw
85: logical petscdrawequals
86: type(tPetscDraw), intent(in) :: A,B
87: end function
88: end interface operator (.eq.)
90: interface operator(.ne.)
91: function petscrandomnotequal(A,B)
92: import tPetscRandom
93: logical petscrandomnotequal
94: type(tPetscRandom), intent(in) :: A,B
95: end function
96: end interface operator (.ne.)
97: interface operator(.eq.)
98: function petscrandomequals(A,B)
99: import tPetscRandom
100: logical petscrandomequals
101: type(tPetscRandom), intent(in) :: A,B
102: end function
103: end interface operator (.eq.)
105: Interface petscbinaryread
106: subroutine petscbinaryreadcomplex(fd,data,num,count,type,z)
107: integer fd
108: PetscComplex data(*)
109: PetscInt num
110: PetscInt count
111: PetscDataType type
112: PetscErrorCode z
113: end subroutine
114: subroutine petscbinaryreadreal(fd,data,num,count,type,z)
115: integer fd
116: PetscReal data(*)
117: PetscInt num
118: PetscInt count
119: PetscDataType type
120: PetscErrorCode z
121: end subroutine
122: subroutine petscbinaryreadint(fd,data,num,count,type,z)
123: integer fd
124: PetscInt data(*)
125: PetscInt num
126: PetscInt count
127: PetscDataType type
128: PetscErrorCode z
129: end subroutine
130: subroutine petscbinaryreadcomplex1(fd,data,num,count,type,z)
131: integer fd
132: PetscComplex data
133: PetscInt num
134: PetscInt count
135: PetscDataType type
136: PetscErrorCode z
137: end subroutine
138: subroutine petscbinaryreadreal1(fd,data,num,count,type,z)
139: integer fd
140: PetscReal data
141: PetscInt num
142: PetscInt count
143: PetscDataType type
144: PetscErrorCode z
145: end subroutine
146: subroutine petscbinaryreadint1(fd,data,num,count,type,z)
147: integer fd
148: PetscInt data
149: PetscInt num
150: PetscInt count
151: PetscDataType type
152: PetscErrorCode z
153: end subroutine
154: subroutine petscbinaryreadcomplexcnt(fd,data,num,count,type,z)
155: integer fd
156: PetscComplex data(*)
157: PetscInt num
158: PetscInt count(1)
159: PetscDataType type
160: PetscErrorCode z
161: end subroutine
162: subroutine petscbinaryreadrealcnt(fd,data,num,count,type,z)
163: integer fd
164: PetscReal data(*)
165: PetscInt num
166: PetscInt count(1)
167: PetscDataType type
168: PetscErrorCode z
169: end subroutine
170: subroutine petscbinaryreadintcnt(fd,data,num,count,type,z)
171: integer fd
172: PetscInt data(*)
173: PetscInt num
174: PetscInt count(1)
175: PetscDataType type
176: PetscErrorCode z
177: end subroutine
178: subroutine petscbinaryreadcomplex1cnt(fd,data,num,count,type,z)
179: integer fd
180: PetscComplex data
181: PetscInt num
182: PetscInt count(1)
183: PetscDataType type
184: PetscErrorCode z
185: end subroutine
186: subroutine petscbinaryreadreal1cnt(fd,data,num,count,type,z)
187: integer fd
188: PetscReal data
189: PetscInt num
190: PetscInt count(1)
191: PetscDataType type
192: PetscErrorCode z
193: end subroutine
194: subroutine petscbinaryreadint1cnt(fd,data,num,count,type,z)
195: integer fd
196: PetscInt data
197: PetscInt num
198: PetscInt count(1)
199: PetscDataType type
200: PetscErrorCode z
201: end subroutine
202: end Interface
204: Interface petscbinarywrite
205: subroutine petscbinarywritecomplex(fd,data,num,type,z)
206: integer fd
207: PetscComplex data(*)
208: PetscInt num
209: PetscDataType type
210: PetscErrorCode z
211: end subroutine
212: subroutine petscbinarywritereal(fd,data,num,type,z)
213: integer fd
214: PetscReal data(*)
215: PetscInt num
216: PetscDataType type
217: PetscErrorCode z
218: end subroutine
219: subroutine petscbinarywriteint(fd,data,num,type,z)
220: integer fd
221: PetscInt data(*)
222: PetscInt num
223: PetscDataType type
224: PetscErrorCode z
225: end subroutine
226: subroutine petscbinarywritecomplex1(fd,data,num,type,z)
227: integer fd
228: PetscComplex data
229: PetscInt num
230: PetscDataType type
231: PetscErrorCode z
232: end subroutine
233: subroutine petscbinarywritereal1(fd,data,num,type,z)
234: integer fd
235: PetscReal data
236: PetscInt num
237: PetscDataType type
238: PetscErrorCode z
239: end subroutine
240: subroutine petscbinarywriteint1(fd,data,num,type,z)
241: integer fd
242: PetscInt data
243: PetscInt num
244: PetscDataType type
245: PetscErrorCode z
246: end subroutine
247: end Interface
249: end module
251: function petscviewernotequal(A,B)
252: use petscsysdefdummy, only: tPetscViewer
253: logical petscviewernotequal
254: type(tPetscViewer), intent(in) :: A,B
255: if (A%v .eq. 0 .or. B%v .eq. 0) then
256: print*, 'PETSc Error: Cannot compare with PETSC_NULL_VIEWER, use PetscObjectIsNull()'
257: ! stop PETSC_ERR_SUP won't compile
258: stop 55
259: endif
260: petscviewernotequal = (A%v .ne. B%v)
261: end function
262: function petscviewerequals(A,B)
263: use petscsysdefdummy, only: tPetscViewer
264: logical petscviewerequals
265: type(tPetscViewer), intent(in) :: A,B
266: if (A%v .eq. 0 .or. B%v .eq. 0) then
267: print*, 'PETSc Error: Cannot compare with PETSC_NULL_VIEWER, use PetscObjectIsNull()'
268: stop 55
269: endif
270: petscviewerequals = (A%v .eq. B%v)
271: end function
273: function petscdrawnotequal(A,B)
274: use petscsysdefdummy, only: tPetscDraw
275: logical petscdrawnotequal
276: type(tPetscDraw), intent(in) :: A,B
277: if (A%v .eq. 0 .or. B%v .eq. 0) then
278: print*, 'PETSc Error: Cannot compare with PETSC_NULL_DRAW, use PetscObjectIsNull()'
279: stop 55
280: endif
281: petscdrawnotequal = (A%v .ne. B%v)
282: end function
283: function petscdrawequals(A,B)
284: use petscsysdefdummy, only: tPetscDraw
285: logical petscdrawequals
286: type(tPetscDraw), intent(in) :: A,B
287: if (A%v .eq. 0 .or. B%v .eq. 0) then
288: print*, 'PETSc Error: Cannot compare with PETSC_NULL_DRAW, use PetscObjectIsNull()'
289: stop 55
290: endif
291: petscdrawequals = (A%v .eq. B%v)
292: end function
294: function petscrandomnotequal(A,B)
295: use petscsysdefdummy, only: tPetscRandom
296: logical petscrandomnotequal
297: type(tPetscRandom), intent(in) :: A,B
298: if (A%v .eq. 0 .or. B%v .eq. 0) then
299: print*, 'PETSc Error: Cannot compare with PETSC_NULL_RANDOM, use PetscObjectIsNull()'
300: stop 55
301: endif
302: petscrandomnotequal = (A%v .ne. B%v)
303: end function
304: function petscrandomequals(A,B)
305: use petscsysdefdummy, only: tPetscRandom
306: logical petscrandomequals
307: type(tPetscRandom), intent(in) :: A,B
308: if (A%v .eq. 0 .or. B%v .eq. 0) then
309: print*, 'PETSc Error: Cannot compare with PETSC_NULL_RANDOM, use PetscObjectIsNull()'
310: stop 55
311: endif
312: petscrandomequals = (A%v .eq. B%v)
313: end function
314: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
315: !DEC$ ATTRIBUTES DLLEXPORT::petscviewernotequal
316: !DEC$ ATTRIBUTES DLLEXPORT::petscviewerequals
317: !DEC$ ATTRIBUTES DLLEXPORT::petscdrawnotequal
318: !DEC$ ATTRIBUTES DLLEXPORT::petscdrawequals
319: !DEC$ ATTRIBUTES DLLEXPORT::petscrandomnotequal
320: !DEC$ ATTRIBUTES DLLEXPORT::petscrandomequals
321: #endif
322: module petscsys
323: use,intrinsic :: iso_c_binding
324: use petscsysdef
325: PetscChar(80) PETSC_NULL_CHARACTER = ''
326: PetscInt PETSC_NULL_INTEGER, PETSC_NULL_INTEGER_ARRAY(1)
327: PetscFortranDouble PETSC_NULL_DOUBLE
328: PetscScalar PETSC_NULL_SCALAR, PETSC_NULL_SCALAR_ARRAY(1)
329: PetscReal PETSC_NULL_REAL, PETSC_NULL_REAL_ARRAY(1)
330: PetscBool PETSC_NULL_BOOL
331: PetscEnum PETSC_NULL_ENUM
332: MPI_Comm PETSC_NULL_MPI_COMM(1)
333: !
334: ! Basic math constants
335: !
336: PetscReal PETSC_PI
337: PetscReal PETSC_MAX_REAL
338: PetscReal PETSC_MIN_REAL
339: PetscReal PETSC_MACHINE_EPSILON
340: PetscReal PETSC_SQRT_MACHINE_EPSILON
341: PetscReal PETSC_SMALL
342: PetscReal PETSC_INFINITY
343: PetscReal PETSC_NINFINITY
345: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
346: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_CHARACTER
347: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_INTEGER
348: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_INTEGER_ARRAY
349: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_DOUBLE
350: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_SCALAR
351: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_SCALAR_ARRAY
352: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_REAL
353: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_REAL_ARRAY
354: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_BOOL
355: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_ENUM
356: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NULL_MPI_COMM
357: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_PI
358: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_MAX_REAL
359: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_MIN_REAL
360: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_MACHINE_EPSILON
361: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_SQRT_MACHINE_EPSILON
362: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_SMALL
363: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_INFINITY
364: !DEC$ ATTRIBUTES DLLEXPORT::PETSC_NINFINITY
365: #endif
367: #include <../src/sys/f90-mod/petscsys.h90>
368: interface
369: #include <../src/sys/f90-mod/ftn-auto-interfaces/petscsys.h90>
370: end interface
371: interface PetscInitialize
372: module procedure PetscInitializeWithHelp, PetscInitializeNoHelp, PetscInitializeNoArguments
373: end interface
375: contains
376: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
377: !DEC$ ATTRIBUTES DLLEXPORT::PetscInitializeWithHelp
378: #endif
379: subroutine PetscInitializeWithHelp(filename,help,ierr)
380: character(len=*) :: filename
381: character(len=*) :: help
382: PetscErrorCode :: ierr
384: if (filename .ne. PETSC_NULL_CHARACTER) then
385: call PetscInitializeF(trim(filename),help,PETSC_TRUE,ierr)
386: CHKERRQ(ierr)
387: else
388: call PetscInitializeF(filename,help,PETSC_TRUE,ierr)
389: CHKERRQ(ierr)
390: endif
391: end subroutine PetscInitializeWithHelp
393: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
394: !DEC$ ATTRIBUTES DLLEXPORT::PetscInitializeNoHelp
395: #endif
396: subroutine PetscInitializeNoHelp(filename,ierr)
397: character(len=*) :: filename
398: PetscErrorCode :: ierr
400: if (filename .ne. PETSC_NULL_CHARACTER) then
401: call PetscInitializeF(trim(filename),PETSC_NULL_CHARACTER,PETSC_TRUE,ierr)
402: CHKERRQ(ierr)
403: else
404: call PetscInitializeF(filename,PETSC_NULL_CHARACTER,PETSC_TRUE,ierr)
405: CHKERRQ(ierr)
406: endif
407: end subroutine PetscInitializeNoHelp
409: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
410: !DEC$ ATTRIBUTES DLLEXPORT::PetscInitializeNoArguments
411: #endif
412: subroutine PetscInitializeNoArguments(ierr)
413: PetscErrorCode :: ierr
415: call PetscInitializeF(PETSC_NULL_CHARACTER,PETSC_NULL_CHARACTER,PETSC_TRUE,ierr)
416: CHKERRQ(ierr)
417: end subroutine PetscInitializeNoArguments
418: end module
420: subroutine PetscSetCOMM(c1,c2)
421: use petscmpi, only: PETSC_COMM_WORLD,PETSC_COMM_SELF
423: implicit none
424: MPI_Comm c1,c2
426: PETSC_COMM_WORLD = c1
427: PETSC_COMM_SELF = c2
428: end
430: subroutine PetscGetCOMM(c1)
431: use petscmpi, only: PETSC_COMM_WORLD
432: implicit none
433: MPI_Comm c1
435: c1 = PETSC_COMM_WORLD
436: end
438: subroutine PetscSetModuleBlock()
439: use petscsys!, only: PETSC_NULL_CHARACTER,PETSC_NULL_INTEGER,&
440: ! PETSC_NULL_SCALAR,PETSC_NULL_DOUBLE,PETSC_NULL_REAL,&
441: ! PETSC_NULL_BOOL,PETSC_NULL_FUNCTION,PETSC_NULL_MPI_COMM
442: implicit none
444: call PetscSetFortranBasePointers(PETSC_NULL_CHARACTER, &
445: & PETSC_NULL_INTEGER,PETSC_NULL_SCALAR, &
446: & PETSC_NULL_DOUBLE,PETSC_NULL_REAL, &
447: & PETSC_NULL_BOOL,PETSC_NULL_ENUM,PETSC_NULL_FUNCTION, &
448: & PETSC_NULL_MPI_COMM, &
449: & PETSC_NULL_INTEGER_ARRAY,PETSC_NULL_SCALAR_ARRAY, &
450: & PETSC_NULL_REAL_ARRAY)
451: end
453: subroutine PetscSetModuleBlockMPI(freal,fscalar,fsum,finteger)
454: use petscmpi, only: MPIU_REAL,MPIU_SUM,MPIU_SCALAR,MPIU_INTEGER
455: implicit none
457: integer4 freal,fscalar,fsum,finteger
459: MPIU_REAL = freal
460: MPIU_SCALAR = fscalar
461: MPIU_SUM = fsum
462: MPIU_INTEGER = finteger
464: end
466: subroutine PetscSetModuleBlockNumeric(pi,maxreal,minreal,eps, &
467: & seps,small,pinf,pninf)
468: use petscsys, only: PETSC_PI,PETSC_MAX_REAL,PETSC_MIN_REAL,&
469: PETSC_MACHINE_EPSILON,PETSC_SQRT_MACHINE_EPSILON,&
470: PETSC_SMALL,PETSC_INFINITY,PETSC_NINFINITY
471: implicit none
473: PetscReal pi,maxreal,minreal,eps,seps
474: PetscReal small,pinf,pninf
476: PETSC_PI = pi
477: PETSC_MAX_REAL = maxreal
478: PETSC_MIN_REAL = minreal
479: PETSC_MACHINE_EPSILON = eps
480: PETSC_SQRT_MACHINE_EPSILON = seps
481: PETSC_SMALL = small
482: PETSC_INFINITY = pinf
483: PETSC_NINFINITY = pninf
485: end