diff options
Diffstat (limited to 'Dragon/src/XELTS2.f')
| -rw-r--r-- | Dragon/src/XELTS2.f | 575 |
1 files changed, 575 insertions, 0 deletions
diff --git a/Dragon/src/XELTS2.f b/Dragon/src/XELTS2.f new file mode 100644 index 0000000..9997187 --- /dev/null +++ b/Dragon/src/XELTS2.f @@ -0,0 +1,575 @@ +*DECK XELTS2 + SUBROUTINE XELTS2( IPRT, IFTEMP,NANGLE,DENUSR,NCODE, + > ANGLES,DENSTY,SWZERO, + > NTOTCL,MAXREM,REMESH,SUBMAX,LINMAX, + > NSUR,NVOL,MATALB,INDEX,MINDIM, + > MAXDIM,ICOORD,INCR,ICUR,TRKBEG,CONV,TRKDIR, + > LENGHT,NUMERO,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the sequential tape that will contain tracks +* or specular BC in 2-D using cyclic tracking. +* +*Copyright: +* Copyright (C) 1990 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): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* IFTEMP tracking file number. +* NANGLE number of angles used in the tracking process. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* NCODE type of boundary conditions. +* ANGLES 3d angle values. +* DENSTY density of tracks angle by angle. +* SWZERO logical value (if .TRUE., use 0 and $\\pi$/2 angles). +* NTOTCL number of cylindres of a type + 2. +* MAXREM max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* SUBMAX max. number of subtracks in a single track. +* LINMAX max. number of track segments in a single track. +* NSUR number of surfaces. +* NVOL number of zones. +* MATALB material types (faces for surfaces). +* INDEX numbering of surfaces & zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* CONV segments of tracks. +* TRKDIR direction of a track in all axes. +* LENGHT relative lenght of each segment in a track. +* NUMERO material identification of each track segment. +* DDENWT density of tracks angle by angle. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT, IFTEMP, NANGLE, NTOTCL, MAXREM, SUBMAX, + > LINMAX, NSUR, NVOL + REAL TRKBEG(NTOTCL), TRKDIR(NTOTCL), CONV(NTOTCL), + > REMESH(MAXREM),DENUSR + DOUBLE PRECISION DENSTY(4*NANGLE),ANGLES(2,4*NANGLE), + > LENGHT(LINMAX),DDENWT(NANGLE) + INTEGER MINDIM(NTOTCL),MAXDIM(NTOTCL),ICUR(NTOTCL), + > ICOORD(NTOTCL),INCR(NTOTCL),NUMERO(LINMAX), + > NCODE(6),MATALB(NSUR:NVOL),INDEX(4,*) +* + REAL TRKEND(2), PROJC2(3), TRKCUT(3,2), + > TRKPTS(3), OLDBEG(2), OLDDIR(2), + > EPS, TOTLEN, ZERO, ONE + DOUBLE PRECISION WEIGHT, ANGTSA(2,2), ANGLE2(2), ABSC(2), DENS, + > DP, RCIRC, PROJ, PMAX, PMIN, DEPART, DENLIN, + > DRKORI(2), RONEPS + INTEGER IOUT, NSCUT(2),INDC(2),IPER(2),IREFL(2) + INTEGER NDIM, IPERG, IDEB, ISUM, ISTRID, IANG, ITX, ITY, + > IDIM, NOTRAK, NANGLS, NSOLMX, IREF1, ITG, + > NSCAN, ISCAN, NTRAC, NPOINT, + > NDEBS, IX, IY, I2, NSGANG, NTTRK, LINACT, + > LINNUS, LINUSD, NCROS, JINT, KINT, II, IZZ, + > NUMANG, I, J, K, LINE, NSUB, ITYPBC + LOGICAL SWZERO, SWZDIR(3), SWBNEW + CHARACTER TEDATA*13 + PARAMETER ( EPS=1.E-5, ZERO= 0.0E0, ONE=1.0E0, IOUT=6 ) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PTSANG,WGTANG, + > DNSANG +*---- +* SCRATCH STORAGE ALLOCATION +* PTSANG: cosines of angles +* WGTANG: weights of angles +* DNSANG: densities of each angle +*---- + ALLOCATE(PTSANG(NANGLE),WGTANG(NANGLE),DNSANG(NANGLE)) +* + NDIM= 2 +* +* SET FLAG FOR SURFACE CROSSING +* IPER(1) = X-PERIOD +* IPER(2) = Y-PERIOD +* VALUES ARE +* IPER(I) = 1 FOR PERIODIC BC +* IPER(I) = 2 FOR OTHER BC + IPER(1)=2 + IPER(2)=2 + IF( NCODE(1).EQ.4 .AND. NCODE(2).EQ.4 ) THEN + IPER(1)=1 + ENDIF + IF( NCODE(3).EQ.4 .AND. NCODE(4).EQ.4 ) THEN + IPER(2)=1 + ENDIF + IPERG= MIN(IPER(1)*IPER(2),2) + ABSC(1)= DBLE(REMESH(MAXDIM(1)))-DBLE(REMESH(MINDIM(1))) + ABSC(2)= DBLE(REMESH(MAXDIM(2)))-DBLE(REMESH(MINDIM(2))) + RCIRC= SQRT(ABSC(1)**2 + ABSC(2)**2) + ABSC(1)= ABSC(1)/RCIRC + ABSC(2)= ABSC(2)/RCIRC +* +* SET ITX THE NUMBER OF X CROSSING +* SET ITY THE NUMBER OF Y CROSSING +* FOR STANDARD TRACKING INCLUDING POINTS AT 0.0 AND PI/2 +* SWZERO =.TRUE. +* SCAN ITX FROM 0 TO NANGLE-1 +* SCAN ITY FROM 0 TO NANGLE-1 +* ONLY VALID VALUE IS ITX+ITY = NANGLE +* FOR MEDI TRACKING EXCLUDING POINT AT O.O AND PI/2 +* SWZERO = .FALSE. +* SCAN ITX FROM 1 TO 2+NANGLE BY STEPS OF 2 +* SCAN ITY FROM 1 TO 2*NANGLE BY STEPS OF 2 +* ONLY VALID VALUES IS ITX+ITY=2*NANGLE + IF( SWZERO )THEN + ISUM= NANGLE-1 + IDEB= 0 + ISTRID=1 + ELSE + ISUM= 2*NANGLE + IDEB= 1 + ISTRID=2 + ENDIF + ALLOCATE(KANGL(SUBMAX)) +* +* FIRST ANGLE INITIALIZATION FOR STORING ON TRACKING FILE +* ANGTSA(1,1)= COS(THETA) WRT X-DIRECTION +* ANGTSA(1,2)= SIN(THETA) WRT X-DIRECTION +* ANGTSA(2,1)= SIN(THETA) WRT X-DIRECTION +* = COS(PI/2-THETA) WRT Y-DIRECTION +* ANGTSA(2,2)= -COS(THETA) WRT Y-DIRECTION +* = SIN(PI/2-THETA) WRT Y-DIRECTION +* 1) GET SUCCESSIVE ANGLES COSINE USING XELTSA +* RANGE 0 <= THETA <= PI/2 +* CAN BE EXTENDED TO 0 <= THETA <= PI +* USING CHANGE OF SIGN FOR ANGTSA(1,1) +* 2) COMPUTE ALL ANGULAR INTEGRATION WEIGHTS USING XELTSW +* 3) STORE ON TRACKING FILE + IANG= 0 + DO 80 ITX= IDEB, ISUM, ISTRID + INDC(1)= ITX + ITY=ISUM-ITX + INDC(2)= ITY +* +* READ ANGLE BY ANGLE + ITYPBC=0 ! Cartesian boundary + CALL XELTSA( NDIM, ITYPBC, ABSC, INDC, DENS, ANGTSA) + IANG= IANG+1 + DENLIN= DENS / RCIRC +* +* FOR HORIZONTAL & VERTICAL ANGLES +* TRAK DENSITY = ORIGINAL DENSITY +* OTHERWISE +* FIND RATIO BETWEEN ORIGINAL DENSITY AND MINIMUM DENSITY +* TRACK DENSITY = CLOSEST MULTIPLE OF MINIMUM TRACK DENSITY + IF( ITX.EQ.0 .OR. ITY.EQ.0 )THEN + DENLIN= DBLE(DENUSR) + DNSANG(IANG)= DENLIN + ELSE + NTRAC= MAX(1,INT(DBLE(DENUSR)/DENLIN+0.5D0)) + DNSANG(IANG)= DBLE(NTRAC) * DENLIN + ENDIF + PTSANG(IANG)= REAL(ANGTSA(1,1)) + ANGLES(1,IANG)= REAL(ANGTSA(1,1)) + ANGLES(2,IANG)= REAL(ANGTSA(2,1)) + 80 CONTINUE +* +* COMPUTE ALL ANGULAR INTEGRATION WEIGHTS + CALL XELTSW( ABSC, NANGLE, PTSANG, WGTANG) + DO 90 IANG= 1, NANGLE + DENSTY(IANG)= 2.0/REAL(WGTANG(IANG)) + IF( IPRT.GT.2 )THEN + WRITE(IOUT,1000) IANG, PTSANG(IANG), WGTANG(IANG), + > DNSANG(IANG), WGTANG(IANG)/DNSANG(IANG) + ENDIF + 90 CONTINUE + DO 100 IANG=1,NANGLE + ANGLES(1,2*NANGLE-IANG+1)=-ANGLES(1,IANG) + ANGLES(2,2*NANGLE-IANG+1)=ANGLES(2,IANG) + DENSTY(2*NANGLE-IANG+1)=DENSTY(IANG) + DDENWT(2*NANGLE-IANG+1)=0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + 100 CONTINUE + DO 110 IANG=1,2*NANGLE + ANGLES(1,4*NANGLE-IANG+1)=ANGLES(1,IANG) + ANGLES(2,4*NANGLE-IANG+1)=-ANGLES(2,IANG) + DENSTY(4*NANGLE-IANG+1)=DENSTY(IANG) + DDENWT(4*NANGLE-IANG+1)=0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + 110 CONTINUE +* +* COPY ANGLES AND DENSITIES ON TEMPORARY TRACKING FILE + WRITE(IFTEMP) ((ANGLES(IDIM,IANG),IDIM=1,NDIM),IANG=1,4*NANGLE) + WRITE(IFTEMP) (DENSTY(IANG) ,IANG=1,4*NANGLE) +* +* PREPARE FOR TRACKING + PROJC2(1)= ZERO + PROJC2(2)= ZERO + PROJC2(3)= ONE + TRKBEG(3)= ZERO + TRKDIR(3)= ZERO + NOTRAK= 0 + NANGLS=NANGLE + NSOLMX= 0 + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,1001) NANGLE + NSOLMX= MIN(9, NANGLE/10) + IREF1=0 + WRITE(IOUT,1002) (IREF1, IZZ=0,NSOLMX) + WRITE(IOUT,1002) (MOD(IZZ,10), IZZ=0,NSOLMX) + TEDATA= '(1H+,TXXX,I1)' + ENDIF +* +* READ SUCCESSIVE ANGLES COSINE USING XELTSA FOR TRACKING + IANG= 0 + DO 120 ITX= IDEB, ISUM, ISTRID + INDC(1)= ITX + ITY=ISUM-ITX + INDC(2)= ITY +* +* READ ANGLE BY ANGLE + ITYPBC= 0 ! Cartesian boundary + CALL XELTSA( NDIM, ITYPBC, ABSC, INDC, DENS, ANGTSA) + IANG= IANG+1 +* +* COMPUTE NUMBER OF SEGMENTS OF THE ANGLE +* ITX = ISUM -> ANGLE = 0 +* ITY = ISUM -> ANGLE = PI/2 + NUMANG=1 + NSCAN = IPERG + IF( ITX.EQ.ISUM )THEN + NSCAN = IPER(1) + ELSEIF( ITY.EQ.ISUM )THEN + NSCAN = IPER(2) + ELSE + NUMANG= ISUM + DO 130 ITG= MIN(ITX,ITY), 2, -1 + IF( (ITX .EQ. (ITX/ITG)*ITG) .AND. + > (ITY .EQ. (ITY/ITG)*ITG) )THEN + NUMANG=NUMANG/ITG + GO TO 135 + ENDIF + 130 CONTINUE + ENDIF + 135 CONTINUE + NUMANG=NUMANG*NSCAN +* +* IF NSCAN = 2 +* 0 TO PI/2 AND PI/2 TO PI ARE SCANNED SIMULTANEOUSLY +* IF NSCAN= 1 +* FIRST TREAT 0 TO PI/2 +* THEN TREAT PI/2 TO PI + DO 140 ISCAN=2,NSCAN,-1 +* +* ZEROS ON THE COMPONENT OF THE DIRECTION + SWZDIR(1)= ITX.EQ.0 + SWZDIR(2)= ITY.EQ.0 + DENLIN = DNSANG(IANG) + DP = 1.D0 / DENLIN + NDEBS= 0 + IF( (IPRT .GT. 1) .AND. (ISCAN .EQ. 2) ) THEN + IF( MOD(IANG,100) .EQ. 0 )THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGLE/10) + WRITE(IOUT,1002)(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,1002)(MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + ELSE + IF( (IPRT.GT.10000) .AND. (MOD(IANG,100).NE.0) )THEN + WRITE(IOUT,1002) (IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,1002) (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + ENDIF + WRITE(TEDATA(7:9),'(I3.3)') MOD(IANG,100) + 2 + WRITE(IOUT,TEDATA) MOD(IANG,10) + ENDIF + ENDIF + DO 150 I = 1, 2 + TRKDIR(I)= REAL(ANGTSA(I,1)) + INCR(I) = 1 + IF( SWZDIR(I) ) INCR(I)= 0 + 150 CONTINUE +* +* CUT LENGHT FOR UNIT PLANE VECTORS +* PROJECT THE 4 CORNERS ON THE PLANE +* +* DIRECTION OF TRACK IS IN O TO PI/2 REPRESENTS ROTATED +X-AXIS +* DIRECTION TRACK NORMAL IS IN -PI/2 TO 0 REPRESENTED +Y-AXIS +* PMIN IS LOWEST POINT FROM PROJECTING CARTESIAN CELL +* IN THIS FRAME OF REFERENCE OF TRACKING LINE +* PMAX IS HIGHEST POINT FROM PROJECTING CARTESIAN CELL +* IN THIS FRAME OF REFERENCE OF TRACKING LINE +* STARTING POINT IN THIS FRAME OF REFERENCE OF TRACKING LINE I +* PMIN-0.5*(MESH SPACING DP) +* STARTING POINT IN ORIGINAL FRAME OF REFERENCE IS +* X=PMIN*ANGTSA(1,2) +* Y=PMIN*ANGTSA(2,2) +* MESH SPACING IN THE ORIGINAL FRAME OF REFERENCE IS +* DX=DP*ANGTSA(1,2) +* DY=DP*ANGTSA(2,2) + PMIN = +1.0D+50 + PMAX = -1.0D+50 + DO 160 IX =MINDIM(1),MAXDIM(1),MAXDIM(1)-MINDIM(1) + DO 161 IY =MINDIM(2),MAXDIM(2),MAXDIM(2)-MINDIM(2) + PROJ = DBLE(REMESH(IX)) * ANGTSA(1,2) + > + DBLE(REMESH(IY)) * ANGTSA(2,2) + PMIN=MIN(PMIN,PROJ) + PMAX=MAX(PMAX,PROJ) + 161 CONTINUE + 160 CONTINUE +* +* NEAREST INTEGER -1 OR +1 FOR SECURITY + NPOINT =NINT((PMAX-PMIN)*DENLIN)+1 + DEPART =PMIN - 0.5D0 * DP + DO 170 J = 1, 2 + DRKORI(J)= DEPART * ANGTSA(J,2) + ANGLE2(J)= DP * ANGTSA(J,2) + 170 CONTINUE + IF(ISCAN .EQ. 1) THEN + IF(ITX .EQ. 0) THEN + TRKDIR(2)=-TRKDIR(2) + INCR(2) =-1 + ELSE IF(ITY.EQ.0) THEN + TRKDIR(1)=-TRKDIR(1) + INCR(1) =-1 + ENDIF + ELSE + ENDIF + SWBNEW= .TRUE. + NSGANG= 0 + IREFL(1)=1 + IREFL(2)=1 + LINACT= 0 + DO 180 I2 = 1,NSCAN*NPOINT + IF( SWBNEW )THEN + NSUB=0 + NTTRK=NOTRAK+1 + LINACT= 1 + LINNUS= LINMAX + IF(NSGANG .EQ. 0) THEN + DO 190 J = 1, 2 + DRKORI(J)= DRKORI(J) + ANGLE2(J) + TRKPTS(J)= REAL(DRKORI(J)) + 190 CONTINUE + ENDIF + IF(ISCAN .EQ. 1 .AND. ITX*ITY .NE. 0) THEN +* +* LOCATE STARTUP POSITION ON SURFACES +* IDENTICAL TO CASE WITH ISCAN=2 + TRKDIR(1)= REAL(ANGTSA(1,1)) + TRKDIR(2)= REAL(ANGTSA(2,1)) + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, + > INCR, TRKPTS, TRKDIR, TRKCUT, NSCUT, + > NCROS, TOTLEN) + IF( NCROS .LT. 2 ) GO TO 185 + TRKPTS(1)=TRKCUT(1,1) + TRKPTS(2)=TRKCUT(2,1) + JINT = (1-MATALB(NSCUT(1)))/2 + TRKDIR(JINT)= -REAL(ANGTSA(JINT,1)) + INCR(JINT) = -1 + ENDIF + ENDIF +* +* LOCATE EXTERNAL SURFACES CROSSED BY THIS TRACK + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKPTS, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +* VALID TRACK ONLY IF 2 SURFACES ARE CROSSED +* OTHERWISE DO NOT CONSIDER TRACK + IF( NCROS .LT. 2 ) GO TO 185 + NSGANG= NSGANG+1 + DO 200 K= 1, NDIM + TRKBEG(K)= TRKCUT(K,1) + TRKEND(K)= TRKCUT(K,2) + 200 CONTINUE + IF( SWBNEW )THEN + DO 210 J= 1, 2 + OLDBEG(J)= TRKBEG(J) + OLDDIR(J)= TRKDIR(J) + 210 CONTINUE + ENDIF +* +* SAVE INITIAL SURFACE CROSSED BY TRACK +* SINCE THE INITIAL IS DOUBLED SET +* LENGTH TO 0.5 TO TAKE THIS EFFECT INTO ACCOUNT + LENGHT(LINACT)= 0.5D0 + NUMERO(LINACT)= NSCUT(1) + LINACT= LINACT + 1 +* +* LOCATE ALL REGIONS CROSSED BY LINE + NSUB=NSUB+1 + IF(NSUB.GT.SUBMAX) CALL XABORT('XELTS2: SUBMAX OVERFLOW.') + KANGL(NSUB)=0 + DO II=1,4*NANGLE + IF((DBLE(TRKDIR(1)).EQ.ANGLES(1,II)).AND. + > (DBLE(TRKDIR(2)).EQ.ANGLES(2,II))) THEN + KANGL(NSUB)=II + GO TO 215 + ENDIF + ENDDO + CALL XABORT('XELTS2: UNABLE TO FIND AN ANGULAR INDEX FOR A' + > //' SUBTRACK') + 215 CALL XELLIN( NDIM, NTOTCL, MAXREM, REMESH, + > NSUR, NVOL, INDEX, MINDIM, MAXDIM, + > ICOORD, ICUR, INCR, TRKBEG, TRKEND, TRKDIR, + > PROJC2, TOTLEN, + > CONV, LINNUS, LENGHT(LINACT), NUMERO(LINACT), + > LINUSD) + LINACT= LINACT + LINUSD + LINNUS= LINNUS - LINUSD +* +* SAVE FINAL SURFACE CROSSED BY TRACK +* SINCE THE FINAL SURFACES IS DOUBLED SET +* LENGTH TO 0.5 TO TAKE THIS EFFECT INTO ACCOUNT + LENGHT(LINACT)= 0.5D0 + NUMERO(LINACT)= NSCUT(2) + LINACT= LINACT + 1 + LINNUS= LINNUS - 1 +* +* FIND INTERSECTION DIRECTION + JINT = (1-MATALB(NSCUT(2)))/2 + KINT = MOD(JINT,2) +1 +* +* IF NCODE(J)=4 +* -> TRANSLATION FOR THE FACE +* FOR LOWER FACE (TRKBEG(J)=REMESH(MINDIM(J))) +* TRKBEG -> REMESH(MAXDIM(J)) +* FOR UPPER FACE (TRKBEG(J)=REMESH(MAXDIM(J))) +* TRKBEG -> REMESH(MINDIM(J)) +* OTHERWISE +* -> SPECULAR REFLECTION FOR THE FACE +* TRKDIR(J)= -TRKDIR(J) +* INCR(J)=-INCR(J) + IF( IPER(JINT).EQ.1 )THEN + IF( TRKEND(JINT).EQ.REMESH(MAXDIM(JINT)) )THEN + TRKEND(JINT)= REMESH(MINDIM(JINT)) + ELSEIF( TRKEND(JINT).EQ.REMESH(MINDIM(JINT)) )THEN + TRKEND(JINT)= REMESH(MAXDIM(JINT)) + ELSE + CALL XABORT('XELTS2: TRANSLATION ERROR') + ENDIF + ELSE + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT)= -INCR(JINT) + ENDIF + RONEPS= ZERO + DO 220 J= 1, 2 + TRKBEG(J)= TRKEND(J) + RONEPS= RONEPS + (TRKBEG(J)-OLDBEG(J))**2 + > + (TRKDIR(J)-OLDDIR(J))**2 + TRKPTS(J)= TRKBEG(J) + 220 CONTINUE + RONEPS=RONEPS/(RCIRC*RCIRC) + SWBNEW= NSGANG.EQ.NUMANG + IF(SWBNEW) THEN + NSGANG=0 + IF(RONEPS .GT. EPS) THEN + WRITE(IOUT,9000) (OLDBEG(J),J=1,2),(TRKBEG(J),J=1,2), + > (OLDDIR(J),J=1,2),(TRKDIR(J),J=1,2), + > 100.0*SQRT(RONEPS) + CALL XABORT + > ('XELTS2: ERROR ON FINAL POSITION OR DIRECTION') + ENDIF +* +* RESET ORIGINAL ANGLES IF ROTATION CONSIDERED + DO 230 II=1,2 + TRKDIR(II)= IREFL(II)*TRKDIR(II) + INCR(II) = IREFL(II)*INCR(II) + IREFL(II) = 1 + 230 CONTINUE + ELSE IF(NSCAN .EQ. 2) THEN + IF(RONEPS .LE. EPS) THEN + IF(IPER(JINT) .EQ. 1) THEN +* +* ROTATE ANGLE IF STARTUP SURFACE PERIODIC + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT)= -INCR(JINT) + IREFL(JINT)=-IREFL(JINT) + SWBNEW= .TRUE. + ELSE IF(IPER(KINT) .EQ. 1) THEN +* +* IF NORMAL SURFACE IS PERIODIC +* LOCATE FIRST NORMAL SURFACE REACHED AND ROTATE ANGLE + DO 240 II=1,NSCAN*NPOINT + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, + > INCR, TRKPTS, TRKDIR, TRKCUT, NSCUT, + > NCROS, TOTLEN) + JINT = (1-MATALB(NSCUT(2)))/2 + IF(JINT.EQ.KINT) GO TO 245 + 240 CONTINUE + CALL XABORT + > ('XELTS2: CANNOT FIND AN INITIAL PERIODIC SURFACE') + 245 CONTINUE + TRKPTS(1)=TRKCUT(1,2) + TRKPTS(2)=TRKCUT(2,2) + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT) = -INCR(JINT) + IREFL(JINT)=-IREFL(JINT) + SWBNEW= .TRUE. + ENDIF + ENDIF + ENDIF + IF( SWBNEW )THEN +* +* NOW, WRITE THE TRACK + NOTRAK= NOTRAK + 1 + NTTRK = NOTRAK + LINE= LINACT-1 + WEIGHT= 0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + WRITE(IFTEMP) NSUB, LINE, WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(I),I=1,LINE), + > (LENGHT(I),I=1,LINE) + IF( IPRT.GT. 1000 ) THEN + WRITE(IOUT,1010) NOTRAK,IANG,LINE + WRITE(IOUT,1011) (LENGHT(I),NUMERO(I),I=1,LINE) + ENDIF + ENDIF + 185 CONTINUE + 180 CONTINUE + 140 CONTINUE + 120 CONTINUE +* + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,1020) IFTEMP,NANGLE, DENUSR,NOTRAK + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(KANGL,PTSANG,WGTANG,DNSANG) + RETURN +* + 1000 FORMAT(1X,I4,': COS=',F15.10,' WGT=',F15.10,' DNS=',F15.10, + > ' WGT/DEN=',F15.10) + 1001 FORMAT(1X,'ECHO = ',I10,' SOLID ANGLES TO BE TRACKED ') + 1002 FORMAT(1X,10(I1,9X)) + 1010 FORMAT(1X,'#',I10,' IANG=',I10,' LEN=',I10) + 1011 FORMAT(1P,(1X,E15.3,1X,I10)) + 1020 FORMAT(1X,'ECHO OF TRACKING PROPERTIES FOR TAPE ',I2/ + > 10X,'NUMBER OF ANGLES =',I10/ + > 10X,' TRACK DENSITY =',F10.3,' LINES/CM'/ + > 10X,'NUMBER OF TRACK STORED =',I10) +* + 9000 FORMAT(1X,'FINAL TRACK POSITION EXPECTED = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK POSITION FOUND = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK DIRECTION EXPECTED = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK DIRECTION FOUND = (', + > F15.10,',',F15.10,')'/ + > 1X,'RMS ERROR = ',F15.10,' %') + END |