[Fortran] 纯文本查看 复制代码
USE ISO_C_Binding
INCLUDE 'CHEM.TXT'
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
TYPE, BIND(C) :: incrmnt
C DOUBLE PRECISION(C_DOUBLE) :: y[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: ddy[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: above[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: below[lenth]
INTEGER(C_int) :: bf,js,gross
C Type(C_PTR), value :: incrmnt *lchild
C Type(C_PTR), value :: incrmnt *rchild
C Type(C_PTR), value :: incrmnt *father
END TYPE incrmnt
C
TYPE, BIND(C) :: strctflag
INTEGER(C_INT) :: IFLAG,NONEAR,GSN,GSO
END TYPE strctflag
C
TYPE, BIND(C) :: ssflag
INTEGER(C_INT) :: nstep,ifind,iinteg,ienlge,irecrd
END TYPE ssflag
C
INTERFACE
integer(c_int) subroutine bisrch BIND(C, Name="bisrch" )
c import
c integer compar(type incrmnt *,type incrmnt *);
c TYPE(C_PTR), VALUE :: p
c integer(c_int),value :: flag,i
END subroutine bisrch
END INTERFACE
type (incrmnt) :: fst
C---------------------------------------------------------------
[Fortran] 纯文本查看 复制代码
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
TYPE, BIND(C) :: incrmnt
C DOUBLE PRECISION(C_DOUBLE) :: y[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: ddy[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: above[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: below[lenth]
INTEGER(C_int) :: bf,js,gross
C Type(C_PTR), value :: incrmnt *lchild
C Type(C_PTR), value :: incrmnt *rchild
C Type(C_PTR), value :: incrmnt *father
END TYPE incrmnt
C
TYPE, BIND(C) :: strctflag
INTEGER(C_INT) :: IFLAG,NONEAR,GSN,GSO
END TYPE strctflag
C
TYPE, BIND(C) :: ssflag
INTEGER(C_INT) :: nstep,ifind,iinteg,ienlge,irecrd
END TYPE ssflag
C
INTERFACE
C subroutine bisrch() BIND(C, Name="bisrch" )
function bisrch(iflag) BIND(C, Name="bisrch" )
C import
C integer compar(type incrmnt *,type incrmnt *)
C TYPE(C_PTR), VALUE :: p
C integer(c_int),value :: flag,i
END function bisrch
C END subroutine bisrch
END INTERFACE
type (strctflag) :: fst
C---------------------------------------------------------------
[Fortran] 纯文本查看 复制代码
SUBROUTINE ISAT
1 (ELWRK, LRW, IELWRK, LIW, ANDTOL, EPSTOL, RNDTOL, STRIDE, YALL)
USE ISO_C_Binding
INCLUDE 'CHEM.TXT'
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
TYPE, BIND(C) :: incrmnt
C DOUBLE PRECISION(C_DOUBLE) :: y[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: ddy[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: above[lenth]
C DOUBLE PRECISION(C_DOUBLE) :: below[lenth]
INTEGER(C_int) :: bf,js,gross
C Type(C_PTR), value :: incrmnt *lchild
C Type(C_PTR), value :: incrmnt *rchild
C Type(C_PTR), value :: incrmnt *father
END TYPE incrmnt
C
TYPE, BIND(C) :: strctflag
INTEGER(C_INT) :: IFLAG,NONEAR,GSN,GSO
END TYPE strctflag
C
TYPE, BIND(C) :: ssflag
INTEGER(C_INT) :: nstep,ifind,iinteg,ienlge,irecrd
END TYPE ssflag
C
INTERFACE
subroutine bisrch() BIND(C, Name="bisrch" )
C function bisrch(pst) BIND(C, Name="bisrch" )
C import
C Type(C_PTR) , value :: pst
C integer compar(type incrmnt *,type incrmnt *)
C TYPE(C_PTR), VALUE :: p
C integer(c_int),value :: flag,i
C END function bisrch
END subroutine bisrch
END INTERFACE
C type (incrmnt) :: fst
type (strctflag) :: fst
C type (ssflag) :: fst
C---------------------------------------------------------------
EXTERNAL BALNCE [C], INSRTD [C], ENLRGE [C],
& FRMEM[C], STATIS[C], FUN, JAC
DIMENSION YALL(KMAX), YTMP(KMAX), YQ(KMAX)
DIMENSION ELWRK(LRW),IELWRK(LIW)
INTEGER(4) nstep, ifind, iinteg, ienlge, irecrd
INTEGER(4) IFLAG, NONEAR, BF, GS, JS, GSN, GSO, GROSS
DOUBLE PRECISION ABOVE, BELOW, Y, DDY
DIMENSION Y(KMAX),DDY(KMAX),RTOL(KMAX),ATOL(KMAX)
DIMENSION ABOVE(KMAX+1),BELOW(KMAX+1),RPAR(KMAX),IPAR(KMAX)
c
real*4 contm,difftm,chemtm,dintm,isatm,intgtm,srchtm,deltm,
& slargetm,baltm,tmchm,tmchm0
common /stime/ difftm, contm, chemtm, dintm, isatm, intgtm,
& srchtm, deltm, slargetm, baltm
common /sflag/ nstep, ifind, iinteg, ienlge, irecrd
common /ode/ neq, mf, itol, iopt, itask, istate,rtol, atol
c
COMMON /FIND/ Y, DDY, ABOVE, BELOW, BF, JS, GROSS
COMMON /strctflag/ IFLAG, NONEAR, GSN, GSO
DO I = 1, KK+1
YTMP(I) = YALL(I)
Y(I) = YTMP(I)
END DO
TMPTM0 = SECNDS(0.0)
call bisrch
TMPTM = SECNDS(0.0)
SRCHTM = SRCHTM + (TMPTM - TMPTM0)
[C] 纯文本查看 复制代码
#include "stdafx.h"
#include <iostream>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <malloc.h>
#include "isatcdef.h"
struct incrmnt
{
double y[lenth];
double ddy[lenth];
double above[lenth];
double below[lenth];
int bf;
int js;
int gross;
struct incrmnt *lchild;
struct incrmnt *rchild;
struct incrmnt *father;
};
struct strctflag
{
int iflag;
int nonear;
int gsn;
int gso;
};
struct ssflag
{ int nstep;
int ifind;
int iinteg;
int ienlge;
int irecrd;
};
struct incrmnt FIND;
struct strctflag FLAG;
struct ssflag SFLAG;
struct incrmnt *phead=NULL,*pfind=NULL,*pfather=NULL,
*pnear=NULL,*q=NULL,*a=NULL,*f=NULL,*b=NULL,*pd=NULL;
double plus[lenth],minus[lenth];
double min=Maxmin;
void bisrch()
{
int compar(struct incrmnt *,struct incrmnt *);
struct incrmnt *p;
int flag,i;
// initialize pfind.
// pfind=(struct incrmnt *)malloc(sizeof(struct incrmnt));
pfind=new incrmnt;
for(i=0;i<=lenth-1;i++)
pfind->y=FIND.y;
pfind->lchild=NULL;
pfind->rchild=NULL;
pfind->father=NULL;
pfind->bf=0;
pfind->js=0;
pfind->gross=0;
if (phead==NULL)
{
phead=pfind;
FLAG.iflag=1;
FLAG.nonear=1;
return;
}
else
/*to find the location for pfind, insert it and adjust the bitree*/
{
f=NULL;a=phead;p=phead;q=NULL;
/*to find the location to insert pfind*/
while(p!=NULL)
{
if(p->bf!=0)
{a=p;f=q;} /* adjustment will start from node a,*/
/* f is the parents node of a */
//p->father=q;
q=p;
flag=compar(pfind,p); /*comparing the keyword*/
if(flag==0)
{
for(i=0;i<=lenth-1;i++)
{
FIND.ddy=p->ddy;
}
p->js=p->js+1;
FIND.js=p->js;
min=Maxmin;
pnear=NULL;
delete pfind;
FLAG.iflag=0;
return;
}
else
if(flag==1)
p=p->lchild;
else
p=p->rchild;
}
if (fabs(min-Maxmin)<=1.e-10)
FLAG.nonear=1;
else
{
FLAG.nonear=0;
for (i=0;i<=lenth-1;i++)
{
FIND.ddy=pnear->ddy;
}
}
FLAG.iflag=1;
return;
}
}
