V3FIT
fdjac_parallel.f90
1  SUBROUTINE fdjac_parallel(j, fcn)
2  USE fdjac_mod, m=>mp, n=>np, ncnt=>ncntp
3 #if !defined(MPI_OPT)
4  IMPLICIT NONE
5 !-----------------------------------------------
6 ! D u m m y A r g u m e n t s
7 !-----------------------------------------------
8  INTEGER :: j
9 !-----------------------------------------------
10 ! L o c a l P a r a m e t e r s
11 !-----------------------------------------------
12  REAL(rprec), PARAMETER :: zero=0
13 !-----------------------------------------------
14 ! L o c a l V a r i a b l e s
15 !-----------------------------------------------
16  INTEGER :: iflag
17 #if defined(CRAY)
18  INTEGER :: i
19 #endif
20  REAL(rprec) :: temp, temp2, h, enorm
21  EXTERNAL fcn, enorm
22 !-----------------------------------------------
23 !
24 ! THIS ROUTINE IS PASSED TO THE MULTI-PROCESSOR HANDLING
25 ! ROUTINE
26 
27  IF (eps .EQ. zero) stop 'EPS = 0 in fdjac_parallel!'
28 
29  temp = xp(j)
30  h = eps*abs(temp)
31  IF (h .eq. zero) h = eps
32  IF( flip(j)) h = -h
33  xp(j) = temp + h
34  iflag = j
35 
36  CALL fcn (m, n, xp, wap, iflag, ncnt)
37 
38  temp2 = enorm(m, wap)
39  WRITE(6, '(2x,i6,7x,1es12.4)') ncnt+j, temp2**2
40 
41 !
42 ! WRITE TO A UNIQUE FILE FOR I/O IN MULTI-PROCESSOR SYSTEM
43 !
44  WRITE (j+1000) j, iflag, h, temp2
45 #if defined(CRAY)
46  DO i = 1,m
47  WRITE (j+1000) wap(i)
48  END DO
49  DO i = 1,n
50  WRITE (j+1000) xp(i)
51  END DO
52 #else
53  WRITE (j+1000) wap
54  WRITE (j+1000) xp
55 #endif
56  CLOSE (j+1000) !!Needed to run correctly in multi-tasking...
57 
58  xp(j) = temp
59 #endif
60  END SUBROUTINE fdjac_parallel