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/othersupmath/charfloatlineparser.f
+99
View File
@@ -0,0 +1,99 @@
subroutine charfloatlineparser(longchar,nmax,charvars,
&nchars,floatvars,nfloats)
implicit none
!7 Sept 2013, revised version
!parse a long line of chars into char and/or float variables with the following assumptions:
!1. Each cell is separated by a separating character which can be either a ',', blank space(s) or anything
!with the ASCII code less than and including 032 or larger than and including 127
!2. Any separating characters at the end of the line are discarded, i.e.
! '1,2,3,4,a,b,c,,,,,,,,,, ,'='1,2,3,4,a,b,c'
!3. If there is no entry between two non-comma separating characters,these two separating characters are treated as one.
! i.e. '1 2 3 4 a b c'='1,2,3,4,a,b,c'
!4. If there is no entry between two commas that are not positioned in the end of the line, a missing value is assumed to
!exist between these two commas and this missing value is denoted with -9999, i.e.
! i.e. '1,,3,4,a,b,c'='1,-9999,3,4,a,b,c'
!5. Comma has priotity as a separating characer. E.g commas and blank spaces are not used simultaneously as
! separating characters in a single line. When both commas and blank spaces appear in the line, comma is
! the saparating character and blank spaces are repalced with '_'
integer nmax,nchars,nfloats
character(*)::longchar
character charvars(nmax+100)*50,achar*50,stringvars(nmax+100)*50
double precision floatvars(nmax)
integer i,j,k,m,n,ndot,nplus,nminus,nd,ne,nCapD,nCapE,leng
!
call charlineparser(longchar,nmax,stringvars,n)
nchars=0
nfloats=0
do j=1,n
ndot=0
nplus=0
nminus=0
nd=0
ne=0
nCapD=0
nCapE=0
leng=LEN_TRIM(stringvars(j))
achar=stringvars(j)(1:leng)
i=leng
5 k=ichar(achar(i:i))
if(k.le.47.or.k.ge.58)then
m=0
if(k.eq.46)then
ndot=ndot+1
m=1
endif
if(k.eq.43)then
nplus=nplus+1
m=1
endif
if(k.eq.45)then
nminus=nminus+1
m=1
endif
if(k.eq.100)then
nd=nd+1
m=1
endif
if(k.eq.101)then
ne=ne+1
m=1
endif
if(k.eq.68)then
nCapD=nCapD+1
m=1
endif
if(k.eq.69)then
nCapE=nCapE+1
m=1
endif
if(m.eq.0)then
nchars=nchars+1
charvars(nchars)=achar(1:leng)
goto 10
endif
endif
i=i-1
if(i.ge.1)goto 5
m=0
if(ndot.gt.1)m=1
if(nplus.gt.1)m=1
if(nminus.gt.1)m=1
if(nd.gt.1)m=1
if(ne.gt.1)m=1
if(nCapD.gt.1)m=1
if(nCapE.gt.1)m=1
if((nplus*nminus).gt.0)m=1
if((nd+ne+nCapD+nCapE).gt.1)m=1
if((nd+ne+nCapD+nCapE).eq.leng)m=1
if(m.eq.1)then
nchars=nchars+1
charvars(nchars)=achar(1:leng)
else
nfloats=nfloats+1
m=len(trim(achar))
call extCharToFloatNum(m,achar,floatvars(nfloats),k)
endif
10 continue
enddo
return
end subroutine charfloatlineparser
dataassim/math/othersupmath/charlineparser.f
+6 -1
View File
@@ -15,7 +15,8 @@
! separating characters in a single line. When both commas and blank spaces appear in the line, comma is
! the saparating character and blank spaces are repalced with '_'
integer nmax,n
character longchar*(*),charvars(nmax+100)*50
character(*)::longchar
character charvars(nmax+100)*50
integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma
!
leng=LEN_TRIM(longchar)
@@ -35,6 +36,10 @@
do i=1,leng
if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
enddo
if(itiscomma.ge.nmax)then
n=0
return
endif
if(itiscomma.gt.0)then
!If the line contains at least one comma, it is assumed a comma separated line
n=0
dataassim/math/othersupmath/doytotime.f
+147
View File
@@ -0,0 +1,147 @@
subroutine doytotime(dayfract,fday,fhour,fmin,fsecond)
implicit none
double precision dayfract,fday,fhour,fmin,fsecond,term
fday=dint(dayfract)
term=(dayfract-fday)*24.0d0
fhour=dint(term)
term=(term-fhour)*60.0d0
fmin=dint(term)
fsecond=(term-fmin)*60.0d0
if(dabs(fsecond-60.0d0).lt.1.0d-8)then
fsecond=0.0d0
fmin=fmin+1.0d0
endif
if(dabs(fmin-60.0d0).lt.(1.0d-8/60.0d0))then
fmin=0.0d0
fhour=fhour+1.0d0
endif
if(dabs(fhour).lt.1.0d-8.and.dabs(fmin).lt.1.0d-8.and.
&dabs(fsecond).lt.1.0d-8)then
if(dabs(fday-1.0d0).gt.1.0d-8)then
fday=fday-1.0d0
fhour=24.0d0
fmin=0.0d0
fsecond=0.0d0
endif
endif
return
end
subroutine doy_to_monthday(month,monthday,year,idoy)
!extract month,day of month from year and day of year
implicit none
integer month,monthday,year,idoy,isitaleapyear,
&i,j,k,ndays(12)
ndays(1)=31
ndays(2)=28+isitaleapyear(year)
ndays(3)=31
ndays(4)=30
ndays(5)=31
ndays(6)=30
ndays(7)=31
ndays(8)=31
ndays(9)=30
ndays(10)=31
ndays(11)=30
ndays(12)=31
k=0
do i=1,12
do j=1,ndays(i)
k=k+1
if(k.eq.idoy)then
month=i
monthday=j
return
endif
enddo
enddo
month=99
monthday=99
return
end
subroutine timestamp(iyear,dayfract,month,monthday,idoy,ihour,
&imin,isecond,chartimestamp)
implicit none
integer iyear,month,monthday,idoy,ihour,imin,isecond,itimestamp
double precision dayfract,fday,fhour,fmin,fsecond
character charyear*4,charmonth*2,charmonthday*2,charhour*2,
&charmin*2,charsecond*2,chartimestamp*14
if(dayfract.lt.1.0d0)dayfract=1.0d0
call doytotime(dayfract,fday,fhour,fmin,fsecond)
idoy=idnint(fday)
ihour=idnint(fhour)
imin=idnint(fmin)
isecond=idnint(fsecond)
call doy_to_monthday(month,monthday,iyear,idoy)
call NumberToChar(iyear,4,charyear)
call NumberToChar(month,2,charmonth)
call NumberToChar(monthday,2,charmonthday)
call NumberToChar(ihour,2,charhour)
call NumberToChar(imin,2,charmin)
call NumberToChar(isecond,2,charsecond)
chartimestamp=
&charyear//charmonth//charmonthday//charhour//charmin//charsecond
return
end
subroutine mnmdyeardoy(tenletters,month,monthday,
&year,idoy,yearfract)
!extract month,day of month, year, day of year, and year fraction (e.g. 2007.15) from
!a string of 10 characters in the exact form as 08-21-2010 (mn-md-year)
implicit none
character tenletters*(*),c*1
integer month,monthday,year,idoy,izero,isitaleapyear,
& i,j,k,n,ndays(12),ntotdays,itime(3)
double precision yearfract
do j=1,3
itime(j)=0
enddo
n=len(tenletters)
k=0
j=1
do i=n,1,-1
c=tenletters(i:i)
if(ichar(c).ge.48.and.ichar(c).le.57)then
itime(j)=itime(j)+(ichar(c)-48)*(10**k)
k=k+1
else
if(k.ne.0)j=j+1
k=0
endif
enddo
year=itime(1)
monthday=itime(2)
month=itime(3)
! izero=48
! month=(ichar(tenletters(1:1))-izero)*10
! month=month+(ichar(tenletters(2:2))-izero)
! monthday=(ichar(tenletters(4:4))-izero)*10
! monthday=monthday+(ichar(tenletters(5:5))-izero)
! year=(ichar(tenletters(7:7))-izero)*1000
! year=year+(ichar(tenletters(8:8))-izero)*100
! year=year+(ichar(tenletters(9:9))-izero)*10
! year=year+(ichar(tenletters(10:10))-izero)
ndays(1)=31
ndays(2)=28+isitaleapyear(year)
ndays(3)=31
ndays(4)=30
ndays(5)=31
ndays(6)=30
ndays(7)=31
ndays(8)=31
ndays(9)=30
ndays(10)=31
ndays(11)=30
ndays(12)=31
ntotdays=365+isitaleapyear(year)
idoy=monthday
do i=1,month-1
idoy=idoy+ndays(i)
enddo
yearfract=dble(year)+dble(idoy)/dble(ntotdays)
return
end
dataassim/math/othersupmath/extCharToFloatNum.f
+2 -1
View File
@@ -5,7 +5,8 @@
!number.
!ierr=0, successful conversion
! =1, conversion failed
character astring*50,cpastring*(*),c*1,d*1
character(*)::cpastring
character astring*50,c*1,d*1
double precision f,fsign,factor
integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
& numchar,ierr,ispartnum,nlength
dataassim/math/othersupmath/fort.2
+1996
View File
File diff suppressed because it is too large Load Diff
dataassim/math/othersupmath/gasdev.f
+29 -29
View File
@@ -71,13 +71,13 @@
return
end
double precision function ran1(idum)
implicit none
integer idum,IA,IM,IQ,IR,NTAB,NDIV
double precision AM,EPS,RNMX
PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
& IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
& RNMX=1.0d0-EPS)
! double precision function ran1(idum)
! implicit none
! integer idum,IA,IM,IQ,IR,NTAB,NDIV
! double precision AM,EPS,RNMX
! PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
! & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
! & RNMX=1.0d0-EPS)
!
! Minimal random number generator of Park and Miller with Bays-Durham shuffle and
! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive
@@ -85,25 +85,25 @@
! thereafter, do not alter idum between successive deviates in a sequence. RNMX
! should approximate the largest floating value that is less than 1.
!
integer j,k,iv(NTAB),iy
save iv,iy
data iv /NTAB*0/,iy /0/
if(idum.le.0.or.iy.eq.0)then
idum=max(-idum,1)
do j=NTAB+8,1,-1
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if(idum.lt.0)idum=idum+IM
if(j.le.NTAB)iv(j)=idum
enddo
iy=iv(1)
endif
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if(idum.lt.0)idum=idum+IM
j=1+iy/NDIV
iy=iv(j)
iv(j)=idum
ran1=dmin1(AM*iy,RNMX)
return
end
! integer j,k,iv(NTAB),iy
! save iv,iy
! data iv /NTAB*0/,iy /0/
! if(idum.le.0.or.iy.eq.0)then
! idum=max(-idum,1)
! do j=NTAB+8,1,-1
! k=idum/IQ
! idum=IA*(idum-k*IQ)-IR*k
! if(idum.lt.0)idum=idum+IM
! if(j.le.NTAB)iv(j)=idum
! enddo
! iy=iv(1)
! endif
! k=idum/IQ
! idum=IA*(idum-k*IQ)-IR*k
! if(idum.lt.0)idum=idum+IM
! j=1+iy/NDIV
! iy=iv(j)
! iv(j)=idum
! ran1=dmin1(AM*iy,RNMX)
! return
! end
dataassim/math/othersupmath/sigmoid.f
+1 -1
View File
@@ -73,7 +73,7 @@
do i=1,6
grad(i)=grad6(i)
enddo
call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6)
call gradsigmoidfunc(0.0d0,a2,b2,c2,x02,x,grad6)
grad(6)=grad(6)-grad6(6)
do i=1,4
grad(6+i)=-grad6(i)
dataassim/math/othersupmath/supmath.f
+111 -1
View File
@@ -1,3 +1,54 @@
subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
implicit none
integer n,imin,imax,i
double precision x(n),xmin,xmax
imin=1
xmin=x(1)
imax=1
xmax=x(1)
do i=2,n
if(x(i).lt.xmin)then
imin=i
xmin=x(i)
endif
if(x(i).gt.xmax)then
imax=i
xmax=x(i)
endif
enddo
return
end
double precision function fdotsec(idotsec)
implicit none
integer idotsec,i,k,j(100),n
k=idotsec
i=1
10 j(i)=mod(k,10)
k=k/10
if(k.gt.0)then
i=i+1
goto 10
endif
fdotsec=0.0d0
do k=1,i
n=10**(i-k+1)
fdotsec=fdotsec+dble(j(k))/dble(n)
enddo
return
end
integer function isitnaninf(x)
!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
implicit none
double precision x
isitnaninf=1
if((x+1.0d0).gt.x)isitnaninf=0
if((x+1.0d0).lt.x)isitnaninf=1
if((x+1.0d0).eq.x)isitnaninf=1
return
end
subroutine sort_shell(n,a,iorder)
!sort array a with the Shell method (from smallest to largest).
!iorder records the original position of each member.
@@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0
cubicroot=root2
return
end
subroutine getcubicroot(p,q,r,root1,root2,root3)
c
implicit double precision(a-h,l,o-z)
c: x^3+p*x^2+q*x+r=0
root1=-9999.0d0
root2=-9999.0d0
root3=-9999.0d0
capq=(p*p-3.0d0*q)/9.0d0
capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
if (capr*capr .lt. capq*capq*capq) then
rtta=dacos(capr/(dsqrt(capq*capq*capq)))
root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
& dsqrt(3.0d0))-p/3.0d0
root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
& dsqrt(3.0d0))-p/3.0d0
else
capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
& capq*capq*capq))**(1.0d0/3.0d0)
if (dabs(capa) .lt. 1.0d-6) then
capb=0.0
else
capb=capq/capa
end if
root2 =(capa+capb)-p/3.0d0
end if
cubicroot=root2
return
end
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine quadraticroots(a,b,c,root1,root2)
implicit none
@@ -531,7 +617,31 @@ c####################################################################
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
enddo
std=dsqrt(std/dble(nsamp-1))
end
end
subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
implicit none
integer nsamp0,nsamp,j
double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
nsamp=0
do j=1,nsamp0
if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
nsamp=nsamp+1
xvar(nsamp)=xvar0(j)
endif
enddo
fmean=0.0d0
do j=1,nsamp
fmean=fmean+xvar(j)
enddo
fmean=fmean/dble(nsamp)
std=0.0d0
do j=1,nsamp
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
enddo
std=dsqrt(std/dble(nsamp-1))
cv=std/fmean
end
c#######################################################################
subroutine reinitialization(x0min,x0likely,
& x0max,x0new,minterval)
dataassim/math/othersupmath/univparser.f
+2 -1
View File
@@ -4,7 +4,8 @@
implicit none
integer nmax,n
double precision vars(nmax+100)
character longchar*(*),astring*50,c*1
character(*)::longchar
character astring*50,c*1
integer i,pos1,pos2,ispartnum,leng,numchar,ierr
!
n=0
dataassim/math/othersupmath/y_aPLUSbx.f
+44
View File
@@ -0,0 +1,44 @@
subroutine y_aPLUSbx(npoints0,x0,y0,a,b)
implicit none
!fit for y=a+bx
integer npoints0
double precision x0(npoints0),y0(npoints0),a,b
integer i,npoints
double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny,
&x(npoints0),y(npoints0)
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
npoints=0
do i=1,npoints0
if(dabs(x0(i)-fn9999).gt.tiny.and.
&dabs(y0(i)-fn9999).gt.tiny)then
npoints=npoints+1
x(npoints)=x0(i)
y(npoints)=y0(i)
endif
enddo
xmean=0.0d0
ymean=0.0d0
do i=1,npoints
xmean=xmean+x(i)
ymean=ymean+y(i)
enddo
xmean=xmean/dble(npoints)
ymean=ymean/dble(npoints)
lxx=0.0d0
lyy=0.0d0
lxy=0.0d0
do i=1,npoints
lxx=lxx+(x(i)-xmean)**2
lyy=lyy+(y(i)-ymean)**2
lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
enddo
if(lxx.ne.0.0d0)then
b=lxy/lxx
a=ymean-b*xmean
else
b=-9999.0d0
a=-9999.0d0
endif
return
end