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).
Related
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?
I'm completely new in Fortran and I need to write some relatively simple codes.
I have some files (various, for example 200 files); each file for the specific node, with some simplification, each file contains:
T(i), X(i)
these are my input and I want to have an output file contain:
T(i) X(i)1 X(i)2 ... X(i)n
the problem is that I can't separate data in different columns of output file, they comes all after each other in 1 column.
My code is :
PROGRAM Output
implicit none
integer ::nn,n,i,j,l
real,dimension(:),allocatable::t,x,y,z
character(len=10)::TD
open(11,file='outputX.txt')
allocate (t(1000),x(1000),y(1000),z(1000))
n=5 ! Number of Files
nn=50 ! Number of Rows in each File
Do i=1,n ! loop for opening different files
write(TD,10)i
write(*,*)TD
open(1,file=TD)
Do l=1,nn ! loop for reading rows in each file
read(1,*)t(j),x(j)
write(11,*)x(j) !!!! This is my PROBLEM, all the data shows in
! one column, I want each file in separately
Enddo
Enddo
10 format('100',i3.3,'')
deallocate(x,y,z,t)
END PROGRAM Output
The output I get is like this :
11
12
13
21
22
23
31
32
33
But in fact I want :
11 21 31
12 22 32
13 23 33
There are several problems with your code
Do i=1,n ! loop for opening different files
write(TD,10)i
write(*,*)TD
open(1,file=TD)
Do l=1,nn ! loop for reading rows in each file
read(1,*)t(j),x(j)
write(11,*)x(j) !!!! This is my PROBLEM, all the data shows in
! one column, I want each file in separately
End do
End do
The index j is completely undefined. You should put j=1 or 0 and j=j+1 somewhere inside the loop.
The other issue is your output. You are reading the files in sequence. It is very hard to print each file into a separate column. A separate row for each file is easy:
write(11,*) x(1:nn)
after the inner loop.
Or with finer control and avoiding a line wrap
write(11,'999(g0,1x)') x(1:nn)
(g0 is a general edit descriptor which uses only the necessary width). This will only work if you fix the j issue I mentioned above!
To put it into separate columns you must
Open all files at the same time, then read from each of them and print the read data in a single write command.
or
Store all the data from all files into separate columns in a 2D array and print the 2D array afterwards.
So what I got is x(1) belongs to 11, x(2) belongs to 12, x(3) belongs to 13 and so on, isn't it? You could try this one:
write(11,100) x(j), x(j+3), x(j+6)
100 format(1X,11F20.4,11F20.4,11F20.4)
The 2D array... for this problem it is backwards
But it should give you some help... (Hopefully)
PROGRAM Output
IMPLICIT NONE
INTEGER, PARAMETER :: nfiles = 5
INTEGER, PARAMETER :: nrows = 50
integer :: iFile, iRow !File and row counter/#
real,dimension(:,:),allocatable :: t,x,y,z !The are now 2D
INTEGER,dimension(nFiles) :: lFile !logical file indexed by file#
LOGICAL,dimension(nFiles) :: Open4Biz !logical for closing
character(len=10)::TD !Unsure about this
open(11,file='outputX.txt')
allocate (t(iRow,iFile),x(iRow,iFile),y(iRow,iFile),z(iRow,iFile))
Open4Biz(:) = .FALSE. !Initialize
!n=5 ! Number of Files ^^Moved up/renamed^^
!nn=50 ! Number of Rows in each File ^^Moved up/renamed^^
Files_Loop1: Do iFile = 1, nFiles !I think that the loop identifier is std f95 (std ifort anyhow)
write(TD,10) iFile !Unsure about this
write(*,*)TD
lFile(iFile) = 10+iFile
open(lFile(iFile),file=TD) !Probably put in some logic if the file is not found
Open4Biz(iFile) = .TRUE.
ENDDO Files_Loop1
Rows_Loop: Do iRow = 1, nn !The loops are backwards from normal
Files_Loop2: Do iFile = 1, nFiles
read(lFile(iFile),*) t(iRow, iFile), x(iRow, iFile)
Enddo Files_Loop2
write(11,*) x(iRow,:)
Enddo Rows_Loop
10 format('100',i3.3,'')
667 CONTINUE !This is label to 'jump to' from a bad open
Files_Loop3: Do iFile = 1, nFiles
IF(Open4Biz(iFile) CLOSE(lFile(iFile))
ENDDO Files_Open_Loop
IF(ALLOCATED(X)) deallocate(x)
IF(ALLOCATED(Y)) deallocate(y)
IF(ALLOCATED(Z)) deallocate(z)
IF(ALLOCATED(T)) deallocate(t)
END PROGRAM Output
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.
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
I am doing something I've done time after time, setting an array to zero in Fortran 90. However, for some reason in this case it is not working, and I have no idea why.
I allocate the array and use A = 0.d0 but when I write out one of the components it prints as 0.4xxx
My array is a module-level array if this makes any difference, and I am initializing it within a subroutine.
Does anybody have an idea why this could be happening?
EDIT: Sorry I have been away therefore haven't responded. This is still happening. I am using gfortran 4.3. I have changed a few things to see if they will help but they haven't. Notice below that I set the elements to zero two ways. Within the loop they are definitely being set to zero, but after the loop at least one element is becoming non-zero for no apparent reason. I know that all other elements are non-zero as well. I changed the array concerned to be a local subroutine array but this has no effect. The following is the code that is giving me wrong output:
subroutine coeff_cube(f, Ng,x_max_8,coeffs)
integer, intent(in) :: Ng
real(8), intent(in) :: f(Ng,Ng,Ng)
real(8), intent(in) :: x_max_8
integer :: i,j,k,ii,jj,kk
real(8) :: Ints(Ng,nmax+1)
real(8), intent(out) :: coeffs(nmax+1,nmax+1,nmax+1)
call cube_ints(x_max_8,Ng,Ints)
write(*,*) "NOW NMAX IS: ", nmax !Prints '24'
coeffs = 0.0d0
do i=1,nmax+1
do j=1,nmax+1
do k=1,nmax+1
coeffs(i,j,k) = 0.d0
write(*,*) coeffs(i,j,k) !Prints 0.0000000000000000 for all i,j,k
end do
end do
end do
write(*,*) coeffs(1,3,28) !Prints a non-zero number
coeffs(1,3,28) = 0.0d0
write(*,*) coeffs(1,3,28) !Prints 0.0000000000000000
do k=1,nmax+1
i=1
j=1
if (i+j+k .GT. nmax+1)then
exit
end if
do j=1,nmax+1
i=1
if (i+j+k .GT. nmax+1)then
exit
end if
do i=1,nmax+1
if (i+j+k .GT. nmax+1)then
exit
end if
do kk=1,Ng
do jj = 1,Ng
do ii = 1,Ng
coeffs(i,j,k) = coeffs(i,j,k) + &
& f(ii,jj,kk)*Ints(ii,i)*Ints(jj,j)*Ints(kk,k)
if(i==1.AND.j==3.AND.k==28)then
if (kk==1) then
write(*,*) coeffs(i,j,k)
end if
end if
end do
end do
end do
end do
end do
end do
write(*,*) coeffs(1,3,28) !Prints 0.0000000000000000
end subroutine
Does anyone have any ideas?
Thanks.
Sorry I have figured it out...
It does in fact set the array to zero, however for some reason I am writing an element that is not in the array (out of bounds). I would have expected it to give me an error rather than write out any old thing, but I guess that's just fortran...
Are you aware that you can initialize an entire array with a single statement?
coeffs = 0.0d
will set all elements of the array to 0.