Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

New changes from l2g

Browse Source 
w
This commit is contained in:
poprhythm
2022-09-12 16:40:28 +00:00
parent 78eb7147d0
commit d713d4f61a
110 changed files with 87672 additions and 1098 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/optimization/odrpack.f
+150 -155
View File
@@ -6,7 +6,7 @@
*DMPREC
DOUBLE PRECISION FUNCTION DMPREC()
implicit none
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
*maxexp
double precision eps,epsneg,xmin,xmax
@@ -209,146 +209,146 @@ c TD = I1MACH(14)
c DMPREC = B ** (1-TD)
call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
*minexp, maxexp,eps,epsneg,xmin,xmax)
*minexp,maxexp,eps,epsneg,xmin,xmax)
DMPREC=eps
RETURN
END
SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep,
*iexp,minexp, maxexp,eps,epsneg,xmin,xmax)
*iexp,minexp,maxexp,eps,epsneg,xmin,xmax)
implicit none
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
double precision eps,epsneg,xmax,xmin
INTEGER i,itemp,iz,j,k,mx,nxres
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
double precision eps,epsneg,xmax,xmin
INTEGER i,itemp,iz,j,k,mx,nxres
double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
&two,y,z,zero, CONV
CONV(i)=dble(i)
one=CONV(1)
two=one+one
zero=one-one
a=one
1 continue
a=a+a
temp=a+one
temp1=temp-a
if (temp1-one.eq.zero) goto 1
b=one
2 continue
b=b+b
temp=a+b
itemp=int(temp-a)
if (itemp.eq.0) goto 2
ibeta=itemp
beta=CONV(ibeta)
it=0
b=one
3 continue
it=it+1
b=b*beta
temp=b+one
temp1=temp-b
if (temp1-one.eq.zero) goto 3
irnd=0
betah=beta/two
temp=a+betah
if (temp-a.ne.zero) irnd=1
tempa=a+beta
temp=tempa+betah
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
negep=it+3
betain=one/beta
a=one
do 11 i=1, negep
a=a*betain
11 continue
b=a
4 continue
temp=one-a
if (temp-one.ne.zero) goto 5
a=a*beta
negep=negep-1
goto 4
5 negep=-negep
epsneg=a
machep=-it-3
a=b
6 continue
temp=one+a
if (temp-one.ne.zero) goto 7
a=a*beta
machep=machep+1
goto 6
7 eps=a
ngrd=0
temp=one+eps
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
i=0
k=1
z=betain
t=one+eps
nxres=0
8 continue
y=z
z=y*y
a=z*one
temp=z*t
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
temp1=temp*betain
if (temp1*beta.eq.z) goto 9
i=i+1
k=k+k
goto 8
9 if (ibeta.ne.10) then
iexp=i+1
mx=k+k
else
iexp=2
iz=ibeta
10 if (k.ge.iz) then
iz=iz*ibeta
iexp=iexp+1
goto 10
endif
mx=iz+iz-1
endif
20 xmin=y
y=y*betain
a=y*one
temp=y*t
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
k=k+1
temp1=temp*betain
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
goto 20
else
nxres=3
xmin=y
endif
endif
minexp=-k
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
mx=mx+mx
iexp=iexp+1
endif
maxexp=mx+minexp
irnd=irnd+nxres
if (irnd.ge.2) maxexp=maxexp-2
i=maxexp+minexp
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
if (i.gt.20) maxexp=maxexp-1
if (a.ne.y) maxexp=maxexp-2
xmax=one-epsneg
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
xmax=xmax/(beta*beta*beta*xmin)
i=maxexp+minexp+3
do 12 j=1,i
if (ibeta.eq.2) xmax=xmax+xmax
if (ibeta.ne.2) xmax=xmax*beta
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
&two,y,z,zero,CONV
CONV(i)=dble(i)
one=CONV(1)
two=one+one
zero=one-one
a=one
1 continue
a=a+a
temp=a+one
temp1=temp-a
if (temp1-one.eq.zero) goto 1
b=one
2 continue
b=b+b
temp=a+b
itemp=int(temp-a)
if (itemp.eq.0) goto 2
ibeta=itemp
beta=CONV(ibeta)
it=0
b=one
3 continue
it=it+1
b=b*beta
temp=b+one
temp1=temp-b
if (temp1-one.eq.zero) goto 3
irnd=0
betah=beta/two
temp=a+betah
if (temp-a.ne.zero) irnd=1
tempa=a+beta
temp=tempa+betah
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
negep=it+3
betain=one/beta
a=one
do 11 i=1, negep
a=a*betain
11 continue
b=a
4 continue
temp=one-a
if (temp-one.ne.zero) goto 5
a=a*beta
negep=negep-1
goto 4
5 negep=-negep
epsneg=a
machep=-it-3
a=b
6 continue
temp=one+a
if (temp-one.ne.zero) goto 7
a=a*beta
machep=machep+1
goto 6
7 eps=a
ngrd=0
temp=one+eps
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
i=0
k=1
z=betain
t=one+eps
nxres=0
8 continue
y=z
z=y*y
a=z*one
temp=z*t
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
temp1=temp*betain
if (temp1*beta.eq.z) goto 9
i=i+1
k=k+k
goto 8
9 if (ibeta.ne.10) then
iexp=i+1
mx=k+k
else
iexp=2
iz=ibeta
10 if (k.ge.iz) then
iz=iz*ibeta
iexp=iexp+1
goto 10
endif
mx=iz+iz-1
endif
20 xmin=y
y=y*betain
a=y*one
temp=y*t
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
k=k+1
temp1=temp*betain
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
goto 20
else
nxres=3
xmin=y
endif
endif
minexp=-k
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
mx=mx+mx
iexp=iexp+1
endif
maxexp=mx+minexp
irnd=irnd+nxres
if (irnd.ge.2) maxexp=maxexp-2
i=maxexp+minexp
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
if (i.gt.20) maxexp=maxexp-1
if (a.ne.y) maxexp=maxexp-2
xmax=one-epsneg
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
xmax=xmax/(beta*beta*beta*xmin)
i=maxexp+minexp+3
do 12 j=1,i
if (ibeta.eq.2) xmax=xmax+xmax
if (ibeta.ne.2) xmax=xmax*beta
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
*DODR
SUBROUTINE DODR
@@ -966,7 +966,6 @@ C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN)
IF (ACCESS) THEN
C SET STARTING LOCATIONS FOR WORK VECTORS
@@ -1050,9 +1049,8 @@ C STORE VALUES INTO THE WORK VECTORS
IWORK(NITERI) = NITER
IWORK(NJEVI) = NJEV
IWORK(IDFI) = IDF
IWORK(INT2I) = INT2
IWORK(INT2I) = INT2
END IF
RETURN
END
*DESUBI
@@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT DODMN
C INITIALIZE NECESSARY VARIABLES
CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
ACCESS = .TRUE.
@@ -5936,7 +5933,6 @@ C INITIALIZE NECESSARY VARIABLES
DIDVCV = .FALSE.
INTDBL = .FALSE.
LSTEP = .TRUE.
C PRINT INITIAL SUMMARY IF DESIRED
IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
@@ -6295,7 +6291,6 @@ C PRINT ITERATION REPORT
END IF
END IF
END IF
C CHECK IF FINISHED
IF (INFO.EQ.0) THEN
@@ -6315,9 +6310,7 @@ C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
GO TO 110
END IF
END IF
150 CONTINUE
IF (ISTOP.GT.0) INFO = INFO + 100
C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
@@ -6329,12 +6322,9 @@ C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
END IF
CALL DUNPAC(NP,BETAC,BETA,IFIXB)
CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED
IF (DOVCV .AND. ISTOP.EQ.0) THEN
IF (DOVCV .AND. ISTOP.EQ.0) THEN
C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
C TO COMPUTE COVARIANCE MATRIX
@@ -6350,8 +6340,6 @@ C TO COMPUTE COVARIANCE MATRIX
+ T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
+ FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
+ NJEV,NFEV,ISTOP,INFO)
IF (ISTOP.NE.0) THEN
INFO = 51000
GO TO 200
@@ -6359,7 +6347,6 @@ C TO COMPUTE COVARIANCE MATRIX
GO TO 200
END IF
END IF
IF (IMPLCT) THEN
CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1)
@@ -6383,9 +6370,7 @@ C TO COMPUTE COVARIANCE MATRIX
END IF
DIDVCV = .TRUE.
END IF
END IF
C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
200 DO 210 I=0,NP-1
@@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT DNRM2_odr
DNRM2_odr = ZERO
GO TO 300
10 ASSIGN 30 TO NEXT
! 10 ASSIGN 30 TO NEXT
10 NEXT=30
SUM = ZERO
NN = N * INCX
C BEGIN MAIN LOOP
I = 1
C 20 GO TO NEXT,(30, 50, 70, 110)
20 GO TO NEXT
! 20 GO TO NEXT
!------------------------------
20 IF(NEXT.EQ.30) goto 30
IF(NEXT.EQ.50) goto 50
IF(NEXT.EQ.70) goto 70
IF(NEXT.EQ.110) goto 110
30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
ASSIGN 50 TO NEXT
! ASSIGN 50 TO NEXT
NEXT=50
XMAX = ZERO
C PHASE 1. SUM IS ZERO
@@ -12089,13 +12082,15 @@ C PHASE 1. SUM IS ZERO
IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C PREPARE FOR PHASE 2.
ASSIGN 70 TO NEXT
! ASSIGN 70 TO NEXT
NEXT=70
GO TO 105
C PREPARE FOR PHASE 4.
100 I = J
ASSIGN 110 TO NEXT
! ASSIGN 110 TO NEXT
NEXT=110
SUM = (SUM / DX(I)) / DX(I)
105 XMAX = DABS(DX(I))
GO TO 115