C ---------------------------------------------------------------------- INTEGER FUNCTION LINKNUM(fs,ifrom,ito,indexr,indexa) C ---------------------------------------------------------------------- C - Returns the linknumber of the link from node ifrom to node ito. C - The link is found using the foward (backward) star of the C - network. C - INCLUDED FILES: #include "dyna.inc" #include "spstruct.inc" C - UNMODIFIED ARGUMENTS: RECORD /forwardstar/ fs INTEGER ifrom INTEGER ito C - MODIFIED ARGUMENTS: INTEGER indexr ! The relative backward star index of the link INTEGER indexa ! The backward star pointer of the link C - MODIFIED GLOBAL DATA: ! NONE C - LOCAL VARIABLES: INTEGER np1,np2,np C - FUNCTIONS CALLED: ! NONE C - RETURN VALUE: ! The link number of the link in question C ---------------------------------------------------------------------- np1 = fs.npoint(ito) np2 = fs.npoint(ito+1)-1 np = np1 DO WHILE(fs.ifwdarc(np,1).NE.ifrom.AND.np.LE.np2) np = np + 1 ENDDO IF (np.GT.np2) THEN LINKNUM = 0 indexr = 0 indexa = 0 ELSE LINKNUM = fs.ifwdarc(np,2) indexr = np-np1+1 indexa = np ENDIF RETURN END C ---------------------------------------------------------------------- INTEGER FUNCTION LINKMOVEINDEX(net,ilink,relabs) C ---------------------------------------------------------------------- C - Returns the movement index of the link ilink relative to its C - downstream node. C - The link is found using the foward (backward) star of the C - network. C - INCLUDED FILES: #include "dyna.inc" #include "network.inc" C - UNMODIFIED ARGUMENTS: RECORD /Road_Network/ net INTEGER ilink INTEGER relabs ! = 0: return relative pointer. = 1 return abs pointer C - MODIFIED ARGUMENTS: ! NONE C - MODIFIED GLOBAL DATA: ! NONE C - LOCAL VARIABLES: INTEGER node INTEGER np,np1,np2 C - FUNCTIONS CALLED: C - RETURN VALUE: ! The movement index of a link into a given node C ---------------------------------------------------------------------- LINKMOVEINDEX = 0 ! Assume the link number is valid IF (relabs.NE.1) THEN LINKMOVEINDEX = net.link(ilink).backindex - + net.fs.npoint(net.link(ilink).idnod) + 1 ELSE LINKMOVEINDEX = net.link(ilink).backindex ENDIF RETURN END C ---------------------------------------------------------------------- INTEGER FUNCTION NODENUM(net,node) C ---------------------------------------------------------------------- C - Convert from a user node number to a DYNASMART node number C - INCLUDED FILES: #include "dyna.inc" #include "network.inc" C - UNMODIFIED ARGUMENTS: RECORD /Road_Network/ net INTEGER node C - MODIFIED ARGUMENTS: ! NONE C - MODIFIED GLOBAL DATA: ! NONE C - LOCAL VARIABLES: ! NONE C - FUNCTIONS CALLED: ! NONE C - RETURN VALUE: ! The DYNASMART node number of the node in question ! zero upon error C ---------------------------------------------------------------------- NODENUM = 0 IF (node.GT.0.AND.node.LE.MAX_NO) THEN NODENUM = net.nodenum(node) IF (NODENUM.NE.0) RETURN ENDIF WRITE(ostr,'(A,I5,A)') + 'Invalid nodenumber conversion requested [',node,']'//CHAR(0) CALL DYNA_ERROR(ostr + ,DYNA_NONFATAL_WARNING + ,DYNA_UNKNOWN_ERROR + ,DYNA_INVALID_NODENUM) RETURN END INTEGER FUNCTION NODEFROMPARAM(net,node) #include "dyna.inc" #include "network.inc" #include "par.inc" RECORD /Road_Network/ net RECORD /Node_Param/ node INTEGER n1 IF (node.id.number.GT.0 + .AND. + node.id.number.LE.MAX_NO) THEN n1 = net.nodenum(node.id.number) IF (n1.EQ.0) THEN WRITE(ostr,'(A,I5,A)') + 'Invalid node from param [',node.id.number,']'//CHAR(0) CALL DYNA_ERROR(ostr + ,DYNA_NONFATAL_WARNING + ,DYNA_INPUT_ERROR + ,DYNA_INVALID_NODENUM) NODEFROMPARAM = 0 ELSE NODEFROMPARAM = n1 ENDIF ELSE WRITE(ostr,'(A,I5,A)') + 'Invalid node from param [',node.id.number,']'//CHAR(0) CALL DYNA_ERROR(ostr + ,DYNA_NONFATAL_WARNING + ,DYNA_INPUT_ERROR + ,DYNA_INVALID_NODENUM) NODEFROMPARAM = 0 ENDIF RETURN END INTEGER FUNCTION LINKFROMPARAM(net,link) #include "dyna.inc" #include "network.inc" #include "par.inc" RECORD /Road_Network/ net RECORD /Link_Param/ link RECORD /Node_Param/ tmpnode INTEGER n1,n2 INTEGER l1 INTEGER rindex,aindex INTEGER LINKNUM !function INTEGER NODEFROMPARAM !function LINKFROMPARAM = 0 IF (link.how_coded + .EQ. + BY_NUMBER) THEN IF (link.id.number.GT.0 + .AND. + link.id.number.LE.net.nlinks) THEN LINKFROMPARAM = link.id.number ELSE WRITE(ostr,'(A,I5,A)') + 'Invalid link from param [',link.id.number,']'//CHAR(0) CALL DYNA_ERROR(ostr + ,DYNA_NONFATAL_WARNING + ,DYNA_INPUT_ERROR + ,DYNA_INVALID_LINK) LINKFROMPARAM = 0 ENDIF ELSE IF (link.how_coded + .EQ. + BY_NODES) THEN tmpnode.id.number = link.id.by_nodes.from n1 = NODEFROMPARAM(net,tmpnode) tmpnode.id.number = link.id.by_nodes.to n2 = NODEFROMPARAM(net,tmpnode) LINKFROMPARAM = 0 IF (n1.NE.0.AND.n2.NE.0) THEN l1 = LINKNUM(net.fs,n1,n2,rindex,aindex) IF (l1.GT.0.AND.l1.LE.net.nlinks) THEN LINKFROMPARAM = l1 ENDIF ENDIF IF (LINKFROMPARAM.EQ.0) THEN WRITE(ostr,'(A,I5,A,I5,A)') + 'Invalid node pair [',n1,'->',n2, + '] in link from param'//CHAR(0) CALL DYNA_ERROR(ostr + ,DYNA_NONFATAL_WARNING + ,DYNA_INPUT_ERROR + ,DYNA_INVALID_LINK) ENDIF ELSE CALL DYNA_ERROR('Request for link from param without '// + 'coding flag'//CHAR(0) + ,DYNA_NONFATAL_WARNING + ,DYNA_INPUT_ERROR + ,DYNA_INVALID_LINK) LINKFROMPARAM = 0 ENDIF RETURN END INTEGER FUNCTION REVERSE_LINK(net,l) Cr - Find the link which is the reverse of link l: Cr - e.g. l=1->2, R(l)=2->1 #include "dyna.inc" #include "network.inc" RECORD /Road_Network/ net INTEGER l INTEGER i,i1,i2,iun i1 = net.fs.npoint(net.link(l).iunod) i2 = net.fs.npoint(net.link(l).iunod+1) - 1 i = i1 iun = net.fs.ifwdarc(i,1) DO WHILE(i.LE.i2.AND. + iun.NE.net.link(l).idnod) i = i + 1 iun = net.fs.ifwdarc(i,1) ENDDO IF (i.LE.i2) THEN REVERSE_LINK = net.fs.ifwdarc(i,2) ELSE REVERSE_LINK = 0 ENDIF RETURN END INTEGER FUNCTION READ_NEXT(buf,type,divstr,from,arg) IMPLICIT NONE CHARACTER buf*(*),divstr*(*) INTEGER type ! 1=INT 2=FLOAT 3=CHAR INTEGER from,to STRUCTURE /INCOMING_ARG/ UNION MAP INTEGER intarg END MAP MAP REAL realarg END MAP MAP CHARACTER chararg*80 END MAP END UNION END STRUCTURE RECORD /INCOMING_ARG/ arg to = LEN(buf) CALL ISOLATE_ARG(buf,divstr,from,to) IF (from.EQ.0.OR.to.EQ.0) THEN ! Error isolating arg READ_NEXT = 0 RETURN ENDIF IF (type.EQ.1) THEN READ(buf(from:to),'(I80)') arg.intarg ELSE IF (type.EQ.2) THEN READ(buf(from:to),'(F80)') arg.realarg ELSE IF (type.EQ.3) THEN READ(buf(from:to),'(A80)') arg.chararg ENDIF READ_NEXT = to + 1 RETURN END SUBROUTINE ISOLATE_ARG(buf,divstr,starta,enda) IMPLICIT NONE CR FINDS NEXT ARGUMENT IN A SUBSTRING OF buf STARTING AT CR START AND ENDING AT END. THE START AND END OF THE ARGUMENT CR ARE RETURNED IN start AND end WHICH ARE SET TO ZERO IF THERE CR IS A PROBLEM CHARACTER buf*(*),divstr*(*) INTEGER starta,enda INTEGER startf,endf INTEGER sl INTEGER i INTEGER dslen LOGICAL found sl = LEN(buf) IF (starta.LE.0.OR.starta.GT.enda.OR.starta.GT.sl) THEN starta = 0 enda = 0 RETURN ENDIF IF (enda.LE.0.OR.enda.GT.sl) THEN starta = 0 enda = 0 RETURN ENDIF dslen = 0 DO WHILE(divstr(dslen+1:dslen+1).NE.CHAR(0) + .AND.dslen.LE.LEN(divstr)) dslen = dslen + 1 ENDDO startf = starta found = .TRUE. DO WHILE (found) found = .FALSE. DO i = 1,dslen IF (buf(startf:startf).EQ.divstr(i:i)) found = .TRUE. ENDDO IF (found) startf = startf + 1 ENDDO found = .FALSE. endf = startf DO WHILE (.NOT.found) found = .FALSE. DO i = 1,dslen IF (buf(endf:endf).EQ.divstr(i:i)) found = .TRUE. ENDDO IF (.NOT.found) endf = endf + 1 ENDDO starta = startf enda = endf - 1 RETURN END REAL FUNCTION RAN1(ISEED) C****************************************************** C USES A LINEAR CONGRUENTIAL METHOD FROM RIPLEY(1987). C CONSTANTS SELECTED FROM TABLE 2.4 (PP.39),LINE 2. C****************************************************** INTEGER*4 ISEED DOUBLE PRECISION M,A,C,OLDSEED PARAMETER (M=2.000**32,A=69069.000,C=1.000) DATA OLDSEED / 1234.000 / IF (ISEED.NE.0.0) THEN OLDSEED = ISEED*1.000 ISEED = 0 ENDIF CR - FIX: Make sure this inting of this does cause a problem OLDSEED = MOD( (OLDSEED*A+C),M ) RAN1 = OLDSEED / M c print*,'random no.= ',ran1 RETURN END REAL FUNCTION RTRI(ISEED) C********************************************************* C THIS FUNCTION CONVERTS VALUES OF UNIFORMLY DISTRIBUTED C RANDOM NUMBERS TO RANDOM NUMBERS WITH A TRIANGULAR C DISTRIBUTION. C********************************************************* RAN = RAN1(ISEED) IF (0.LE.RAN.AND.RAN.LT.0.5) THEN RTRI = SQRT((RAN/2.0)) ELSE RTRI = 1.0 - SQRT((0.5*(1-RAN))) ENDIF c print*,' rtri= ',rtri RETURN END