diff options
Diffstat (limited to 'Dragon/src/XCWROD.f')
| -rw-r--r-- | Dragon/src/XCWROD.f | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/Dragon/src/XCWROD.f b/Dragon/src/XCWROD.f new file mode 100644 index 0000000..258e725 --- /dev/null +++ b/Dragon/src/XCWROD.f @@ -0,0 +1,195 @@ +*DECK XCWROD + SUBROUTINE XCWROD(NRIN,NRODS,NRODR,RODR,RODP,RADC,NFSEG,NLSEG, + > SEGLEN,NRSEG,NNSEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform rod tracking for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1992 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* NRIN current region number. +* NRODS integer description of rod type: +* NRODS(1) = number of rod; +* NRODS(2) = number of subrods in rod. +* NRODR subrod region. +* RODR subrod radius. +* RODP rod position: +* RODP(1,IRD) = X-position; +* RODP(2,IRD) = Y-position. +* RADC Y-position of track. +* +*Parameters: output +* NFSEG initial segment position. +* NLSEG final segment position. +* SEGLEN length of track. +* NRSEG region crossed by track. +* NNSEG region crossed by track (left). +* +*---------------------------------------------------------------------- +* + INTEGER NRIN,NRODS(2),NRODR,NFSEG,NLSEG,NRSEG(*),NNSEG(*) + REAL RODR(*),RODP(2,*) + DOUBLE PRECISION SEGLEN(*),RADC,RADR,RADR2 +*---- +* FILL IN SEGLEN FROM THE END STARTING WITH ROD FURTHER FROM +* TRACK STARTING POINT UNTIL CENTER OF TRACK REACHED +*---- + NPROD=(NRODS(1)+3)/2 + NSBR=NRODS(2) + IF(RADC.GE.0.0D0) THEN + IPDEB=1 + IPFIN=NPROD + IPSTP=1 + IMDEB=NPROD + IMFIN=1 + IMSTP=-1 + ELSE + RADR=RODP(2,1)-RADC + IF(ABS(RADR).LT.RODR(NSBR)) THEN + IPDEB=NRODS(1)+1 + IPFIN=MAX(2,NRODS(1)+1-NPROD) + ELSE + IPDEB=NRODS(1) + IPFIN=MAX(1,NRODS(1)-NPROD) + ENDIF + IPSTP=-1 + IMDEB=IPFIN + IMFIN=IPDEB + IMSTP=1 + ENDIF + NXSEG=NLSEG + DO 100 IRZ=IPDEB,IPFIN,IPSTP + IF(IRZ.EQ.NRODS(1)+1) THEN + IRD=1 + ELSE + IRD=IRZ + ENDIF + RADR=RODP(2,IRD)-RADC + RADR2=RADR*RADR + NREG=NRIN + IF( ABS(RADR).LT.RODR(NSBR) ) THEN +*---- +* ROD INTERCEPS +*---- + XTRA=SQRT(RODR(NSBR)*RODR(NSBR)-REAL(RADR2)) + XLST=RODP(1,IRD)+XTRA + XFST=RODP(1,IRD)-XTRA + IF(XLST.LT.0.0) THEN +*---- +* CENTER OF TRACK REACHED/EXIT +*---- + GO TO 1000 + ELSE +*---- +* SET POINTERS TO SEGLEN VECTOR W.R.T. LAST POSITION FREE +*---- + NFLSEG=NXSEG-2*NSBR + NLLSEG=NXSEG + NXSEG=NFLSEG + ENDIF + SEGLEN(NLLSEG)=XLST + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NRODR + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=XFST + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + DO 110 ISBR=NSBR-1,1,-1 + IF( ABS(RADR).LT.RODR(ISBR) ) THEN +*---- +* SUBROD INTERCEPS +*---- + XTRA=SQRT(RODR(ISBR)*RODR(ISBR)-REAL(RADR2)) + SEGLEN(NLLSEG)=RODP(1,IRD)+XTRA + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NREG-1 + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=RODP(1,IRD)-XTRA + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + ENDIF + 110 CONTINUE + ENDIF + 100 CONTINUE + 1000 CONTINUE + NLSEG=NXSEG +*---- +* FILL IN SEGLEN FROM THE BEGINNING STARTING WITH ROD CLOSEST FROM +* TRACK STARTING POINT UNTIL CENTER OF TRACK REACHED +*---- + NXSEG=NFSEG + DO 200 IRZ=IMDEB,IMFIN,IMSTP + IF(IRZ.EQ.NRODS(1)+1) THEN + IRD=1 + ELSE + IRD=IRZ + ENDIF + RADR=RODP(2,IRD)-RADC + RADR2=RADR*RADR + NREG=NRIN + IF( ABS(RADR).LT.RODR(NSBR) ) THEN +*---- +* ROD INTERCEPS +*---- + XTRA=SQRT(RODR(NSBR)*RODR(NSBR)-REAL(RADR2)) + XLST=RODP(1,IRD)+XTRA + XFST=RODP(1,IRD)-XTRA + IF(XLST.LT.0.0) THEN +*---- +* SET POINTERS TO SEGLEN VECTOR W.R.T. FIRST POSITION FREE +*---- + NLLSEG=NXSEG+2*NSBR + NFLSEG=NXSEG + NXSEG=NLLSEG + ELSE +*---- +* CENTER OF TRACK REACHED/EXIT +*---- + GO TO 2000 + ENDIF + SEGLEN(NLLSEG)=XLST + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NRODR + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=XFST + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + DO 210 ISBR=NSBR-1,1,-1 + IF( ABS(RADR).LT.RODR(ISBR) ) THEN +*---- +* SUBROD INTERCEPS +*---- + XTRA=SQRT(RODR(ISBR)*RODR(ISBR)-REAL(RADR2)) + SEGLEN(NLLSEG)=RODP(1,IRD)+XTRA + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NREG-1 + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=RODP(1,IRD)-XTRA + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + ENDIF + 210 CONTINUE + ENDIF + 200 CONTINUE + 2000 CONTINUE + NFSEG=NXSEG + RETURN + END |