Newton Method for Nonlinear set of Equations - fortran

I'm a rookie in programming in Fortran90. I used NR method for a system of non-linear equations found in Numerical Recipes and put together a code that does not generate any errors when I compile with GFortran. Problem is, it does not generate any value for output either.
Could it be because my initial guess root value far off from actual root or have I made an error in this code?
Any help/advice on this matter will be highly appreciated.
program main
implicit real*8(a-h,o-z)
parameter(n=4)
logical check
real*8 x(n),fvec(n),fjac(n)
open(20,file="output1.txt",status="unknown")
do i=1,n
x(i)= 4.
enddo
call mnewt(ntrial,x,n,tolx,tolf)
call usrfun(x,n,fvec,fjac)
do i=1,n
write(20,*) 'x(',i,')=',x(i),fvec(i)
enddo
end
subroutine mnewt(ntrial,x,n,tolx,tolf)
integer n,ntrial,np
real*8 tolf,tolx,x(n)
parameter (np=15)
!uses lubksb, ludcmp, usrfun
! Given an initial guess x for a root in n dimensions, take ntrial Newton-Raphson steps to
! improve the root. Stop if the root converges in either summed absolute variable increments
! tolx or summed absolute function values tolf.
integer i,k,indx(np)
real*8 d,errf,errx,fjac(np,np),fvec(np),p(np)
do 14 k=1,ntrial
call usrfun(x,n,fvec,fjac)
errf=0.
do 11 i=1,n
errf=errf+abs(fvec(i))
11 continue
if(errf.le.tolf)return
do 12 i=1,n
p(i)=-fvec(i)
12 continue
call ludcmp(fjac,n,np,indx,d)
call lubksb(fjac,n,np,indx,p)
errx=0.
do 13 i=1,n
errx=errx+abs(p(i))
x(i)=x(i)+p(i)
13 continue
if(errx.le.tolx)return
14 continue
return
end
subroutine usrfun(x,n,fvec,fjac)
implicit none
integer n
real*8 x(n),fvec(n),fjac(n,n), hl, ul, br, bl
hl=1.00
ul=1.00
br=0.20
bl=0.00
! Initial guesses
x(1)=0.0
x(2)=1.5
x(3)=0.5
x(4)=0.5
fvec(1)=(x(2))+(2*sqrt((x(1))))-ul-(2*(sqrt(hl)))
fvec(2)=((x(3))*(x(4)))-((x(1))*(x(2)))
fvec(3)=((x(3))*(x(4))*(x(4)))+(0.5*(x(3))*(x(3)))-((x(1))*(x(2))*(x(2)))-(0.5*(x(1))*(x(1)))+(0.5*(br-bl)*x(1)+x(3))
fvec(4)=(x(4))-sqrt((x(3)))
fjac(1,1)=((x(1))**(-0.5))
fjac(1,2)=1
fjac(1,3)=0
fjac(1,4)=0
fjac(2,1)=(-x(2))
fjac(2,2)=(-x(1))
fjac(2,3)=x(4)
fjac(2,4)=x(3)
fjac(3,1)=((x(2))**2)-(x(1))+(0.5)*(br-bl)
fjac(3,2)=-2*((x(1))*(x(2)))
fjac(3,3)=((x(4))*(x(4)))+(x(3))+(0.5)*(br-bl)*(x(3))
fjac(3,4)=2*((x(3))*(x(4)))
fjac(4,1)=0
fjac(4,2)=0
fjac(4,3)=-0.5*((x(3))**(-0.5))
fjac(4,4)=1
end subroutine usrfun
subroutine ludcmp(a,n,np,indx,d) !fjac=a
integer n,np,indx(n),nmax
real*8 d,a(np,np),tiny
parameter (nmax=2500,tiny=1.0e-20)
integer i,imax,j,k
real*8 aamax,dum,sum,vv(nmax)
d=1.
do 12 i=1,n
aamax=0.
do 11 j=1,n
if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
! print*,a(21,j)
11 continue
! print*,i,aamax
! pause
if (aamax.eq.0.) pause 'singular matrix in ludcmp'
vv(i)=1./aamax
12 continue
do 19 j=1,n
do 14 i=1,j-1
sum=a(i,j)
do 13 k=1,i-1
sum=sum-a(i,k)*a(k,j)
13 continue
a(i,j)=sum
14 continue
aamax=0.
do 16 i=j,n
sum=a(i,j)
do 15 k=1,j-1
sum=sum-a(i,k)*a(k,j)
15 continue
a(i,j)=sum
dum=vv(i)*abs(sum)
if (dum.ge.aamax) then
imax=i
aamax=dum
endif
16 continue
if (j.ne.imax)then
do 17 k=1,n
dum=a(imax,k)
a(imax,k)=a(j,k)
a(j,k)=dum
17 continue
d=-d
vv(imax)=vv(j)
endif
indx(j)=imax
if(a(j,j).eq.0.)a(j,j)=tiny
if(j.ne.n)then
dum=1./a(j,j)
do 18 i=j+1,n
a(i,j)=a(i,j)*dum
18 continue
endif
19 continue
return
end
!lubksb
subroutine lubksb(a,n,np,indx,b)
integer n,np,indx(n)
real*8 a(np,np),b(n)
integer i,ii,j,ll
real*8 sum
ii=0
do 12 i=1,n
ll=indx(i)
sum=b(ll)
b(ll)=b(i)
if (ii.ne.0)then
do 11 j=ii,i-1
sum=sum-a(i,j)*b(j)
11 continue
else if (sum.ne.0.) then
ii=i
endif
b(i)=sum
12 continue
do 14 i=n,1,-1
sum=b(i)
do 13 j=i+1,n
sum=sum-a(i,j)*b(j)
13 continue
b(i)=sum/a(i,i)
14 continue
return
end

You provide no values for ntrial, tolx or tolf in your call to mnewt. What values do you want the algorithm to use?
Your initial guess with x(1)=0.0 results in a divide by zero when computing fjac(1,1)=((x(1))**(-0.5)).
Your arrays fjac and a appear to be mis-dimensioned throughout. Surely they should have shape [n,n]?
I made the following changes to your code:
> diff mine.f90 yours.f90
5c5
< real*8 x(n),fvec(n),fjac(n,n)
---
> real*8 x(n),fvec(n),fjac(n)
10c10
< call mnewt(10,x,n,1.d-6,1.d-6)
---
> call mnewt(ntrial,x,n,tolx,tolf)
68c68
< x(1)=0.1
---
> x(1)=0.0
100c100
< real*8 d,a(n,n),tiny
---
> real*8 d,a(np,np),tiny
165c165
< real*8 a(n,n),b(n)
---
> real*8 a(np,np),b(n)
Running my version writes this as output:
x( 1 )= 0.1000000014901161 -0.8675444632541631
x( 2 )= 1.5000000000000000 9.9999997764825821E-02
x( 3 )= 0.5000000000000000 0.5299999967962503
x( 4 )= 0.5000000000000000 -0.2071067811865476
Is that what you expect?
It took me about five minutes to diagnose these issues by compiling using the NAG Fortran compiler with full runtime checking enabled.

Related

Explicit Forward-Difference Method in Fortran Programming(Gives Overflow)-(what inputs should be given)

Question Link-(https://drive.google.com/file/d/1A9Vf-e1qbdNZxa_UQ2cy8K4LiEfubU6X/view?usp=sharing)
The problem is with inputs when I give the inputs it gives me overflow error
Code That is written for solving the problem:-
COMMON/VARI/U(0:101),V(0:101)
REAL K,KP
DATA T,X1,X2,KP/0,0,1,1/
P(T)= 0
Q(T)= 0
F(X)= 100*SIN(PI*X)
E(X,T)=100*EXP(-PI*PI*T)*SIN(PI*X)
PRINT*,'ENTER TMAX,N,K'
READ*,TMAX,N,K
H=(X2-X1)/N
R=(KP*K)/(H*H)
PI = 4*ATAN(1.0)
! SET INITIAL CONDITION============================================
DO I =0,N
X=X1+I*H
V(I)=F(X)
END DO
! DEFINE TRADITIONAL LINEAR SYSTEM==
15 DO I=1,N-1
U(I)=V(I)+R*(V(I-1)-2*V(I)+V(I+1))
END DO
T=T+K
U(0)=P(T)
U(N)=Q(T)
! WRITE U OVER V TO PREPARE FOR NEXT TIME STEP==
DO I =0,N
V(I)= U(I)
END DO
!IF T IS LESS THAN TMAX , TAKE A TIME STEP===
IF(ABS(TMAX-T).GT.K/2) GOTO 15
! OTHERWISE PRINT RESULT
WRITE (2,110) N,K,TMAX,T
WRITE (3,120)
DO I=0,N
X=X1+I*H
EXACT=E(X,T)
ER=ABS(EXACT-U(I))
WRITE(6,130)X,U(I),EXACT,ER
END DO
110 FORMAT(2x,'N=',I4,2x,'K=',F8.6,2x,'TMAX=',F5.2,2x,'implT=',F5.2/)
120 FORMAT(2x,'x=',F5.2,5x,'NUMERICAL',F10.2,5X,'EXAT',5X,'ER',/)
130 FORMAT(3x,F4.2,2x,3F13.6)
STOP
END

Using MPI_PUT in fortran and different ranks have different displacements using c_loc

I have MPI ranks split up to calculate different parts an an array, then I want to put/send those slices onto a different rank that doesn't participate in the calculation. That rank is the master of a new communicator set up to do other things with the array (averaging, IO, etc). I got it to work with MPI_isend and MPI_irecv, and now I want to try MPI_Put.
use mpi_f08
use iso_c_binding
implicit none
integer, parameter :: n=10, gps = 18, pes=12, dpes = 6
integer :: main=pes, d=dpes
integer :: diag_master
integer :: global_size, global_rank, diag_size, diag_rank
type(MPI_comm),allocatable :: diag_comm
integer :: pelist_diag
TYPE(MPI_Win) :: win
integer :: ierr, i, j
type(MPI_COMM) :: comm, mycomm
integer :: gsz, grk
integer :: lsz, lrk
integer(KIND=MPI_ADDRESS_KIND) :: local_group
logical :: local_flag
integer :: color,key
!!! THIS IS THE ARRAY
real, dimension(n,pes) :: r
!!!
logical :: on_dpes = .false.
logical,allocatable,dimension(:) :: dpes_list ! true if on dpes list
integer :: comm_manager
integer :: dmg
integer(KIND=MPI_ADDRESS_KIND) :: buff_size !< the size of a variable type
integer(kind=MPI_ADDRESS_KIND) :: displacement
integer :: disp_size
integer :: loc_base
integer, pointer :: fptr
!!!!!!!! THIS ALL WORKS BEGIN !!!!!!!!
comm=MPI_COMM_WORLD
call MPI_INIT(ierr)
call MPI_COMM_SIZE(COMM, gsz, ierr)
call MPI_COMM_RANK(COMM, grk, ierr)
allocate(dpes_list(gsz))
! write (6,*) "I am ",grk," of ",gsz
!> Find the group
call MPI_COMM_GET_ATTR(COMM,MPI_APPNUM,local_group,local_flag,ierr)
!> Split a new communicator as mycom
color = int(local_group)
key = 0
call MPI_COMM_SPLIT(COMM, color, key, mycomm, ierr)
!> Get information about the split communicators
call mpi_comm_size(mycomm,lsz,ierr)
call mpi_comm_rank(mycomm,lrk,ierr)
!> Create data on the main communicator
if (lsz == pes) then
comm_manager = main
on_dpes = .false.
r = 0.0
if (mod(lrk,2) == 0) then
c_loop: do concurrent (i=1:n)
r(i,lrk+1) = sin(real(i))+real(i)
enddo c_loop
else
r(:,lrk+1) = 10.0-dble(lrk)
endif
if (lsz == dpes) then
diag_size = lsz
diag_rank = lrk
comm_manager = d
on_dpes = .true.
diag_comm = mycomm
if (lrk==0) then
dmg = grk
endif
endif
call MPI_ALLGATHER(on_dpes,1,MPI_LOGICAL, &
dpes_list,gsz,MPI_LOGICAL, MPI_COMM_WORLD, ierr)
!> Get the master of dpes
do i=1,gsz
if (dpes_list(i)) then
dmg = i-1
exit
endif
enddo
diag_master = dmg
diag_global_master = dmg
!!!!!!!! THIS ALL WORKS END !!!!!!!!
!! At this point, the ranks that participate in the calculation
!! have values in r(i,lrk+1) where lrk is their rank
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!! THIS IS WHERE THINGS GO WRONG? !!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
disp_size = storage_size(r)
buff_size = disp_size*size(r)
call c_f_pointer(c_loc(r(1,1)),fptr)
loc_base = fptr
nullify(fptr)
write (6,*) loc_base, grk
call MPI_Win_create(loc_base,buff_size,disp_size,MPI_INFO_NULL,&
mpi_comm_world,win,ierr)
call MPI_Win_Fence(0,win,ierr)
displacement = loc_base + disp_size *buff_size
! if (.not.allocated(diag_comm)) then
if (grk == 11) then
call MPI_Put(r(:,global_rank+1),size(r,1),MPI_FLOAT,&
diag_master,displacement,size(r,1), MPI_FLOAT, win ,ierr)
endif
call MPI_Win_Fence(0,win,ierr)
CALL MPI_WIN_FREE(win, ierr)
call MPI_FINALIZE(ierr)
I have ! if (.not.allocated(diag_comm)) then commented out because I tried to do this with all of the ranks that calculate r, but I got the same result.
I am compiling with mpiifort -O0 -fpe0 -init=snan,arrays -no-wrap-margin -traceback -stand f18 and run with mpirun -n 12 ./$#.x : -n 6 ./$#.x in my Makefile. The version of mpiifort I am using is
> mpiifort -v
mpiifort for the Intel(R) MPI Library 2019 Update 2 for Linux*
Copyright 2003-2019, Intel Corporation.
ifort version 19.0.2.187
The output (write (6,*) loc_base, grk)is strange.
1072411986 0
0 1
0 2
0 3
0 4
0 5
0 6
0 7
0 8
0 9
0 10
0 11
2142952877 12
2142952877 13
2142952877 14
2142952877 15
2142952877 16
2142952877 17
Rank 12-17 are the ranks that don't participate in "calculating r", but I'm not sure why c_loc(r(1,1)) is different for these ranks. Also, it is different for rank 0.
My actual questions are
1) How do I calculate the displacement variable? Am I doing it correctly? Is it supposed to be different between ranks because it will be in this case?
2) Why is c_loc(r(1,1)) different for the ranks 12-17? Does it have anything to do with the fact that this is a SPMD program? Why is it different for rank 0?
3) Can I do the one way communication with all of the ranks instead of just one? I had each rank call mpi_isend, and then i just called mpi_irecv in a loop through all of the ranks sending when I did this the other way. Can I do something similar with MPI_Put? Should I be using MPI_Get? Something else?
4) How do I get this to work? This is just an educational example for myself, and what I actually need to do is much more complicated.
I can answer item 2, at least. You have:
call c_f_pointer(c_loc(r(1,1)),fptr)
loc_base = fptr
where loc_base is declared integer. You seem to be assuming that loc_base is some sort of address, but it is not. In Fortran, intrinsic assignment from a pointer assigns the value of the target, not the location of the target. So you're effectively doing a TRANSFER of the REAL values of r to loc_base - probably not what you want.

Fortran error common block

Where is the problem? Someone please give me the solution. Errors are:
WARNING - Common block "P/" was previously defined as size 128 but is now defined as size 1320
WARNING - Common block "P/" was previously defined as size 128 but is now defined as size 1320
I don't have any idea to solve it.
This is a mathematical problem solving program.
IMPLICIT REAL*8(A-H,O-Z)
COMMON/P/FW,AK,PR,GC,DA,XQ,SC,EC,DU,SR,RE,FS,XR,XK,RM1,GR
COMMON/V/IR,IX
COMMON/VV/G1,G2,G3
OPEN (1, FILE='MS99.dat',STATUS='UNKNOWN')
OPEN (2, FILE='MMS109.dat',STATUS='UNKNOWN')
FW=1.0
AK=1.0
GR=0.0
PR=10.0
GC=0.8
DA=1.0
XQ=1.0
SC=2.0
EC=2.0
DU=0.1
SR=0.1
RE=0.1
FS=0.5
XR=0.7
DU=0.9
XK=0.8
RM1= (1+(16/(3*XR)))
IR=80
IX=20
G1=0.0001
G2=0.0001
G3=0.0001
CALL DRFFO
CALL COMP1
1 FORMAT(2X,F6.2,2X,14F9.4)
2 FORMAT(2X,7(A6,F13.7))
CLOSE(1)
CLOSE(2)
STOP
END
C****************DERFO********************
SUBROUTINE DRFFO
IMPLICIT REAL*8(A-H,O-Z)
COMMON/P/FW,AK,PR,GC,DA,XQ,SC,EC,DU,SR,RE,FS,XR,XK,RM1,GR
COMMON/V/IR,IX
COMMON/VV/G1,G2,G3
DIMENSION XD(50),XK(3,50),X(50),F(50)
EXTERNAL DERFO
N=28
ITMAX=8
EPS=0.000001
KK=0
555 KK=KK+1
IF (KK.EQ.100)STOP
WRITE (*,*) 'IR=',IR
DO 101 ITER=1,IR
T=0.0
DO K=1,N
X(K)=0.0
ENDDO
X(1)=FW
X(2)=1.0
X(3)=G1
X(4)=1.0
X(5)=G2
X(6)=1.0
X(7)=G3
X(10)=1.0
X(18)=1.0
X(28)=1.0
H=0.01
DO I=1,IR
CALL RKSYS(DERFO,T,H,X,XD,XK,F,N)
DO K=1,N
X(K)=XD(K)
ENDDO
T=T+H
ENDDO
A11=X(9)**2+X(11)**2+X(13)**2+X(10)**2+X(12)**2+X(14)**2
A12=X(9)*X(16)+X(11)*X(18)+X(13)*X(20)+X(10)*X(17)+X(12)*X(19)
1 +X(14)*X(21)
A13=X(9)*X(23)+X(11)*X(25)+X(13)*X(27)+X(10)*X(24)+X(12)*X(26)
1 +X(14)*X(28)
A21=A12
A22=X(16)**2+X(18)**2+X(20)**2+X(17)**2+X(19)**2+X(21)**2
A23=X(16)*X(23)+X(18)*X(25)+X(20)*X(27)+X(17)*X(24)+X(19)*X(26)
1 +X(21)*X(28)
A31=A13
A32=A23
A33=X(23)**2+X(25)**2+X(27)**2+X(24)**2+X(26)**2+X(28)**2
B1=-(X(2)*X(9)+X(4)*X(11)+X(6)*X(13)+X(3)*X(10)+X(5)*X(12)
1 +X(7)*X(14))
B2=-(X(2)*X(16)+X(4)*X(18)+X(6)*X(20)+X(3)*X(17)+X(5)*X(19)
1 +X(7)*X(21))
B3=-(X(2)*X(23)+X(4)*X(25)+X(6)*X(27)+X(3)*X(24)+X(5)*X(26)
1 +X(7)*X(28))
ERR=X(2)**2+X(3)**2+X(4)**2+X(5)**2+X(6)**2+X(7)**2
WRITE(*,29)'G1=',G1,'G2=',G2,'G3=',G3,'ERR=',ERR
DG=(A11*(A22*A33-A23*A32)-A12*(A21*A33-A23*A31)+A13*(A21*A32-
1 A22*A31))
DG11=(B1*(A22*A33-A23*A32)-A12*(B2*A33-A23*B3)+A13*(B2*A32-A22*B3)
1 )
DG1=DG11/DG
DG22=(A11*(B2*A33-A23*B3)-B1*(A21*A33-A23*A31)+A13*(A21*B3-B2*A31)
1 )
DG2=DG22/DG
DG33=(A11*(A22*B3-B2*A32)-A12*(A21*B3-B2*A31)+B1*(A21*A32-A22*A31)
1 )
DG3=DG33/DG
IF(ERR.LT.EPS)GOTO 22
G1=G1+DG1
G2=G2+DG2
G3=G3+DG3
IF(ITER.GE.ITMAX)THEN
IR=IR+IX
GO TO 555
END IF
101 CONTINUE
22 WRITE (2,29)'ERR=',ERR,'G1=',G1,'G2=',1/G2,'G3='
1 ,-G3
29 FORMAT (2X,4(A6,F13.7))
RETURN
END SUBROUTINE
C**********************COMP1**************************
SUBROUTINE COMP1
IMPLICIT REAL*8(A-H,O-Z)
COMMON/P/FW,AK,PR,GC,DA,XQ,SC,EC,DU,SR,RE,FS,XR,XK,RM1,GR
COMMON/V/IR,IX
COMMON/VV/G1,G2,G3
DIMENSION XD(50),XK(3,50),F(50),X(50)
EXTERNAL DERFO
N=7
T=0.0
DO K=1,N
X(K)=0.0
ENDDO
X(1)=FW
X(2)=1.0
X(3)=G1
X(4)=1.0
X(5)=G2
X(6)=1.0
X(7)=G3
X(10)=1.0
X(18)=1.0
X(28)=1.0
H=0.01
WRITE(1,50)'eta','X(2)','g1','X(4)','g2','X(6)','g3'
WRITE(1,30)T,X(2),X(3),X(4),X(5),X(6),X(7)
DO I=1,IR
CALL RKSYS(DERFO,T,H,X,XD,XK,F,N)
DO K=1,N
X(K)=XD(K)
ENDDO
T=T+H
IF(I/5*5.EQ.I)THEN
WRITE(1,30)T,X(2),X(3),X(4),X(5),X(6),X(7)
ENDIF
ENDDO
50 FORMAT(A8,2X,A7,2X,A7,2X,A7,2X,A7,2X,A7,2X,A7)
30 FORMAT(2X,F6.2,2X,6F9.4)
RETURN
END
c*********************DERFO************************
SUBROUTINE DERFO(X,T,F,N)
IMPLICIT REAL*8(A-H,O-Z)
COMMON/P/FW,AK,PR,GC,DA,XQ,SC,EC,DU,SR,RE,FS,XR,XK,RM1,GR
DIMENSION X(N),F(N)
C PI=4.*ATAN(1.0)
F(1)=X(2)
F(2)=X(3)
F(3)=(FS/DA)*X(2)*X(2)+(X(1)/(DA*RE))+AK*X(1)-GC*X(6)-GR*X(4)-X(1)
1 *X(3)
F(10)=(FS/DA)*2*X(2)*X(9)+X(8)/(DA*RE)+AK*X(8)-GC*X(13)-GR*X(11)-
1 X(1)*X(10)-X(3)*X(8)
F(17)=(FS/DA)*2*X(2)*X(16)+X(15)/(DA*RE)+AK*X(15)-GC*X(20)-GR*
1 X(18)-X(1)*X(17)-X(3)*X(15)
F(24)=(FS/DA)*2*X(2)*X(23)+X(22)/(DA*RE)+AK*X(22)-GC*X(27)-GR*
1 X(25)-X(1)*X(24)-X(3)*X(22)
F(4)=X(5)
F(5)=(-1*(PR*X(1)*X(5)+PR*DU*F(7)+PR*XQ*X(4)+PR*EC*X(3)*X(3))/RM1)
F(12)=(-1*(PR*X(1)*X(12)+PR*X(5)*X(8)+PR*DU*F(14)+PR*XQ*X(11)+PR*
1 EC*2*X(3)*X(10))/RM1)
F(19)=(-(PR*X(1)*X(19)+PR*X(5)*X(15)+PR*DU*F(21)+PR*XQ*X(18)+PR*
1 EC*2*X(3)*X(17))/RM1)
F(26)=(-(PR*X(1)*X(26)+PR*X(5)*X(22)+PR*DU*F(28)+PR*XQ*X(25)+PR*
1 EC*2*X(3)*X(24))/RM1)
F(6)=X(7)
F(7)=XK*X(6)-SC*X(1)*X(7)-SC*SR*F(5)
F(8)=X(9)
F(9)=X(10)
F(11)=X(12)
F(13)=X(14)
F(14)=XK*X(13)-SC*X(1)*X(14)-SC*X(7)*X(8)-SC*SR*F(12)
F(15)=X(16)
F(16)=X(17)
F(18)=X(19)
F(20)=X(21)
F(21)=XK*X(20)-SC*X(1)*X(21)-SC*X(7)*X(15)-SC*SR*F(19)
F(22)=X(23)
F(23)=X(24)
F(25)=X(26)
F(27)=X(28)
F(28)=XK*X(27)-SC*X(1)*X(28)-SC*X(7)*X(22)-SC*SR*F(26)
RETURN
END
C******************IMPLICIT R-K SIXTH ORDER METHOD*******************
SUBROUTINE RKSYS(DERIVS,T,H,X,XD,XK,F,N)
IMPLICIT REAL*8(A-H,O-Z)
DIMENSION X(N),XD(N),XK(4,N),F(N)
SQT=SQRT(15.0)
A1=(5.-SQT)/10.0
A2=1.0/2.0
A3=(5.+SQT)/10.0
B1=5.0/36.0
B2=(10.0-3.0*SQT)/45.0
B3=(25.0-6.0*SQT)/180.0
C1=(10.0+3.0*SQT)/72.0
C2=2.0/9.0
C3=(12.0-3.0*SQT)/72.0
D1=(25.0+6.0*SQT)/180.0
D2=(10.0+3.0*SQT)/45.0
D3=5.0/36.0
CALL DERIVS(X,T,F,N)
DO I=1,N
XK(1,I)=H*F(I)
XK(2,I)=H*F(I)
XK(3,I)=H*F(I)
XD(I)=X(I)+B1*XK(1,I)+B2*XK(2,I)+B3*XK(3,I)
ENDDO
CALL DERIVS(XD,T+A1*H,F,N)
DO I=1,N
XK(1,I)=H*F(I)
XD(I)=X(I)+C1*XK(1,I)+C2*XK(2,I)+C3*XK(3,I)
ENDDO
CALL DERIVS(XD,T+A2*H,F,N)
DO I=1,N
XK(2,I)=H*F(I)
XD(I)=X(I)+D1*XK(1,I)+D2*XK(2,I)+D3*XK(3,I)
ENDDO
CALL DERIVS(XD,T+A3*H,F,N)
DO I=1,N
XK(3,I)=H*F(I)
XD(I)=X(I)+(5.0*XK(1,I)+8.0*XK(2,I)+5.0*XK(3,I))/18.0
ENDDO
RETURN
END
It is just a warning and they can be normally be ignored but this is not advised. The common block /P/ has an element XK:
COMMON/P/FW,AK,PR,GC,DA,XQ,SC,EC,DU,SR,RE,FS,XR,XK,RM1,GR
in the main program it does not get a size/ dimension and is a scalar. In the subroutines it gets a size XK(3,50):
DIMENSION XD(50),XK(3,50),X(50),F(50)
and thus is and array with 150 elements (i.e. 1200 bytes).
It is advised that the DIMENSION statement is also placed in the main program.
As a side note, I hope you didn't write the code as it is very old fashioned (normally one would use modules etc. for the variables in this case).

How can I create code for specific variable?

I want to embed a code for Fortran 95.
For example: I have read an integer variable
read *, x
for instance x=4. and my source creates four loop which has four loop variable
loop1:do a=1,16
loop2:do b=1,16
loop3:do c=1,16
loop4:do d=1,16
........smt......
end do loop4
end do loop3
end do loop2
end do loop1
I'm working on a such a code that tries for finding a magic square. I can find a magic code by using a algorithm for odd numbered square matrices. probably, I also can generate a magic square which is even numbered and double-even numbered. however , I'm trying to improve my coding skills by writing a program that tries element by element to find magic square.
implicit integer (a-z)
counte=possibility counter , magcon=magic square generated counter
god and devil are logical variables. But I used them as integer.
integer GG(3,3),COUNTE,magcon
integer god,devil
open(55,file='mymagics')
COUNTE=0
magcon=0
loop1:do a=9,1,-1
loop2:do b=9,1,-1
loop3:do c=9,1,-1
loop4:do d=9,1,-1
loop5:do e=9,1,-1
loop6:do f=9,1,-1
loop7:do g=9,1,-1
loop8:do h=9,1,-1
loop9:do i=9,1,-1
these loops are for evaluating elements
GG(1,1)=a
GG(1,2)=b
GG(1,3)=c
GG(2,1)=d
GG(2,2)=e
GG(2,3)=f
GG(3,1)=g
GG(3,2)=h
GG(3,3)=i
call elementcontrol(gg,devil)
if(devil.eq.1)then
call magiccontrol(GG,god)
else if(devil.eq.0) then
cycle
endif
COUNTE=COUNTE+1
if(allah.eq.1) then
magcon=magcon+1
write(55,66)
write(55,*) counte ,"possibility is tried"
write(55,*)"**************************************"
write(55,*)"**************************************"
write(55,*)"**************************************"
write(55,*)"--------------------------------------"
write(55,*)GG(1,1),GG(1,2),GG(1,3)
write(55,*)GG(2,1),GG(2,2),GG(2,3)
write(55,*)GG(3,1),GG(3,2),GG(3,3)
write(55,*)"--------------------------------------"
write(55,*)"**************************************"
write(55,*)"**************************************"
write(55,*)"**************************************"
write(55,66)
66 format(//)
else
print *, counte ,"possibility is unvalid"
end if
enddo loop9
enddo loop8
enddo loop7
enddo loop6
enddo loop5
enddo loop4
enddo loop3
enddo loop2
enddo loop1
print *, "finally done!"
print *, magcon,"magic square is found"
stop
end
subroutine magiccontrol(magic,logic)
integer logic,z
integer magic(3,3),sumrow(3),sumcol(3),sumdia(2)
these are row,column and diagonal sum finder
do z=1,3
sumrow(z)=0
sumcol(z)=0
sumdia(z)=0
end do
do 31 k=1,3
do 31 l=1,3
sumrow(k)=sumrow(k)+(magic(k,l))
31 continue
do 52 m=1,3
do 52 n=1,3
sumcol(m)=sumcol(m)+(magic(n,m))
52 continue
do 69 i=1,3
sumdia(1)=sumdia(1)+magic(i,i)
sumdia(2)=sumdia(2)+magic((4-i),i)
69 continue
loop1:do y=1,3
loop2:do f=1,3
loop3:do x=1,2
if(sumrow(y).eq.15) then
if(sumcol(f).eq.15)then
if(sumdia(x).eq.15)then
logic=1
else
logic=0
exit loop1
end if
else
logic=0
exit loop1
end if
else
logic=0
exit loop1
end if
end do loop3
end do loop2
end do loop1
15 is magic constant. loops are for evaluate whether a aquare is magic or not.
end
subroutine elementcontrol(elecon,logic2)
integer elecon(3,3),a1,a2,a3,a4,a5,a6,coun(9)
do a4=1,9
coun(a4)=0
end do
logic2=0
do a1=1,9
do a2=1,3
do a3=1,3
if(a1.eq.elecon(a2,a3))then
coun(a1)=coun(a1)+1
end if
end do
end do
end do
do a5=1,9
do a6=1,9
if(a5.ne.a6) then
if(coun(a5).eq.coun(a6)) then
logic2=1
else
logic2=0
exit
end if
else
cycle
end if
end do
end do
there loops are to evaluate whether every element is different from each other or not.
end
Now the problem is that if I will be inclined to increase number of rows and columns of magic square, I have to rewrite element specifier loops. But I'm not willing to that. So I want to declare a variable,read it , and be able to make program create do loops as read.
I wish I was crystal clear about what I want to know.
The test could look something like this:
LOGICAL FUNCTION IsMagical(dim_o_square, SquareData)
IMPLICIT NONE
INTEGER , INTENT(IN ) :: Dim_o_Square
REAL, DIMENSION(Dim_o_Square, Dim_o_Square), INTENT(IN ) :: SquareData
REAL, DIMENSION(Dim_o_Square) :: Row_Sum, Col_Sum
REAL :: Diag_Sum
IsMagical = .FALSE.
INTEGER :: I
IF(Dim_o_Square < 2) THEN
WRITE(*,*) '[SubMagic?:line10] DIMENSION of square is hosed'
RETURN
ENDIF
! Fill the data to determine PFM'ness
DIAG = 0
DO I = 1, Dim_o_Square
COL_Sum(I) = SUM(SquareData(:,I))
ROW_Sum(I) = SUM(SquareData(I,:))
DIAG_Sum = Diag + SquareData(I,I)
ENDDO
! Test for PFM'ness
DO I = 2, Dim_o_Square
IF( COL(I) /= Diag .OR. ROW(I) /= Diag ) THEN
RETURN
ENDIF
ENDDO
!Must be magical at this point...
IsMagical = .TRUE.
WRITE(*,*) '[SubMagic?:line40] Magical and sum value (Row/Col/Diag)=', DIAG_Sum
RETURN
END FUNCTION IsMagical
Perhaps there is some carry over in concepts for producing the square?

least squares minimisation fortran 77

Trying to get a one-parameter least squares minimisation working in fortran77. Here's the code; it compiles and seems to work except....it gets caught in an infinite loop between values of h1= 1.8E-2 and 3.5E-2.
Having a look now but, odds are, I'm not going to have much luck sussing the issue on my own. All help welcome!
PROGRAM assignment
! A program designed to fit experiemental data, using the method
! of least squares to minimise the associated chi-squared and
! obtain the four control parameters A,B,h1 and h2.
!*****************************************************************
IMPLICIT NONE
INTEGER i
DOUBLE PRECISION t(17),Ct(17),eCt(17)
DOUBLE PRECISION h1loop1,h1loop2,deltah,Cs
DOUBLE PRECISION chisqa,chisqb,dchisq
OPEN(21, FILE='data.txt', FORM='FORMATTED', STATUS='OLD')
DO i=1,17
READ(21,*)t(i),Ct(i),eCt(i)
END DO
CLOSE(21)
!Read in data.txt as three one dimensional arrays.
!*****************************************************************
!OPEN(21, FILE='outtest.txt', FORM='FORMATTED', STATUS='NEW')
!DO i=1,17
! WRITE(21,*)t(i),Ct(i),eCt(i)
!END DO
!CLOSE(21)
!
!Just to check input file is being read correctly.
!*****************************************************************
!**********************Minimising Lamda1 (h1)*********************
deltah= 0.0001
h1loop2= 0.001
h1loop1= 0.0 !Use initial value of 0 to calculate start-point chisq
DO 10
chisqa= 0.0
DO 20 i= 1, 17
Cs= exp(-h1loop1*t(i))
chisqa= chisqa + ((Ct(i) - Cs)/eCt(i))**2
20 END DO
chisqb= 0.0
DO 30 i= 1, 17
h1loop2= h1loop2 + deltah
Cs= exp(-h1loop2*t(i))
chisqb= chisqb + ((Ct(i) - Cs)/eCt(i))**2
30 END DO
!Print the two calculated chisq values to screen.
WRITE(6,*) 'Chi-squared a=',chisqa,'for Lamda1=',h1loop1
WRITE(6,*) 'Chi-squared b=',chisqb,'for Lamda1=',h1loop2
dchisq= chisqa - chisqb
IF (dchisq.GT.0.0) THEN
h1loop1= h1loop2
ELSE
deltah= deltah - ((deltah*2)/100)
END IF
IF (chisqb.LE.6618.681) EXIT
10 END DO
WRITE(6,*) 'Chi-squared is', chisqb,' for Lamda1 = ', h1loop2
END PROGRAM assignment
EDIT: Having looked at it again I've decided I have no clue what's screwing it up. Should be getting a chi-squared of 6618.681 from this, but it's just stuck between 6921.866 and 6920.031. Help!
do i=1
is not starting a loop, for a loop you need to specify an upper bound as well:
do i=1,ub
that's why you get the error message about the doi not having a type, in fixed format spaces are insignificant...
Edit: If you want to have an infinite loop, just skip the "i=" declaration completely. You can use an exit statement to leave the loop, when a certain criterion has been reached:
do
if (min_reached) EXIT
end do
Edit2: I don't know why you stick to F77 fixed format. Here is your program in free format, with some fixes of places, which looked weird, without digging too much into the details:
PROGRAM assignment
! A program designed to fit experiemental data, using the method
! of least squares to minimise the associated chi-squared and
! obtain the four control parameters A,B,h1 and h2.
!*****************************************************************
IMPLICIT NONE
integer, parameter :: rk = selected_real_kind(15)
integer, parameter :: nd = 17
integer :: i,t0
real(kind=rk) :: t(nd),t2(nd),Ct(nd),eCt(nd),Ctdiff(nd),c(nd)
real(kind=rk) :: Aa,Ab,Ba,Bb,h1a,h1b,h2a,h2b,chisqa,chisqb,dchisq
real(kind=rk) :: deltah,Cs(nd)
OPEN(21, FILE='data.txt', FORM='FORMATTED', STATUS='OLD')
DO i=1,nd
READ(21,*) t(i),Ct(i),eCt(i)
END DO
CLOSE(21)
!Read in data.txt as three one dimensional arrays.
!*****************************************************************
!OPEN(21, FILE='outtest.txt', FORM='FORMATTED', STATUS='NEW')
!DO i=1,17
! WRITE(21,*)t(i),Ct(i),eCt(i)
!END DO
!CLOSE(21)
!
!Just to check input file is being read correctly.
!*****************************************************************
!****************************Parameters***************************
Aa= 0
Ba= 0
h1a= 0
h2a= 0
!**********************Minimising Lamda1 (h1)*********************
deltah= 0.001_rk
h1b= deltah
minloop: DO
chisqa= 0
DO i= 1,nd
Cs(i)= exp(-h1a*t(i))!*Aa !+ Ba*exp(-h2a*t(i))
Ctdiff(i)= Ct(i) - Cs(i)
c(i)= Ctdiff(i)**2/eCt(i)**2
chisqa= chisqa + c(i)
h1a= h1a + deltah
END DO
! Use initial h1 value of 0 to calculate start-point chisq.
chisqb= 0
DO i= 1,nd
h1b= h1b + deltah
Cs(i)= exp(-h1b*t(i))!*Ab !+ Bb*exp(-h2b*t(i))
Ctdiff(i)= Ct(i) - Cs(i)
c(i)= Ctdiff(i)**2/eCt(i)**2
chisqb= chisqb + c(i)
END DO
! First-step h1 used to find competing chisq for comparison.
WRITE(6,*) 'Chi-squared a=', chisqa,'for Lamda1=',h1a
WRITE(6,*) 'Chi-squared b=', chisqb,'for Lamda1=',h1b
! Prints the two calculated chisq values to screen.
dchisq= chisqa - chisqb
IF (dchisq.GT.0) THEN
h1a= h1b
ELSE IF (dchisq.LE.0) THEN
deltah= (-deltah*2)/10
END IF
IF (chisqb.LE.6000) EXIT minloop
END DO minloop
WRITE(6,*) 'Chi-squared is', chisqb,'for Lamda1=',h1b
END PROGRAM assignment