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