SUBROUTINE TRANS(IPRTRA)

COMMON /CELLI/ AI,BI,CI,ALPI,BETI,GAMI,VOLI

COMMON /CELLF/ AF,BF,CF,ALPF,BETF,GAMF,VOLF

COMMON /CONST1/ RADIAN

COMMON /COSANG/ COSA,COSB,COSG

COMMON /DOTP/ S11,S22,S33,S23,S13,S12

COMMON /ERR2/ IERR2

COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3

COMMON /PROB2/ IPCH,NUNK

COMMON /UNIT2/ IUNITB

COMMON /UNIT4/ IUNITD

C**

COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,

$ ICK028,ICK029

C*

C

C

C SUBROUTINE 'TRANS' ...

C TRANSFORM INITIAL CELL PARAMETERS

C

C THE INITIAL CELL (AI,BI,CI,ALPI,BETI,GAMI) IS TRANSFORMED BY

C THE MATRIX (U1,V1,W1 / U2,V2,W2 / U3,V3,W3)

C

C

C --- WRITES:

C IUNITD (=10) (REDUCED CELLS,

C ONLY WHEN EXECUTING RSS PROGRAM FUNCTION)

C

C

C

C --- CALCULATE DETERMINANT AND CHECK FOR A VALID

C TRANSFORMATION MATRIX. FOR THE RSS PROGRAM FUNCTION, THE

C PROGRAM EXECUTION IS STOPPED IN *DETERM* IF THE DETERMINANT

C IS NOT GREATER THAN ZERO (SHOULD NOT OCCUR)

CALL DETERM

IF(IERR2.EQ.0) GO TO 100

C

C --- INVALID MATRIX WHEN EXECUTING TRANS PROGRAM FUNCTION

C (DETERMINANT OF MATRIX IS ZERO, >= 100, OR <= -100),

C WRITE TRANSFORMATION MATRIX, ERROR MESSAGE,

C AND GO TO NEXT PROBLEM

CALL OUTPT1(11)

WRITE(IUNITB,6000)

GO TO 400

100 CONTINUE

C

AR = ALPI/RADIAN

BR = BETI/RADIAN

GR = GAMI/RADIAN

C

C --- CALCULATE A

CALL DOT (U1,V1,W1,U1,V1,W1,AI,BI,CI,AR,BR,GR,S11)

AF = SQRT(S11)

C

C --- CALCULATE B

CALL DOT (U2,V2,W2,U2,V2,W2,AI,BI,CI,AR,BR,GR,S22)

BF = SQRT(S22)

C

C --- CALCULATE C

CALL DOT (U3,V3,W3,U3,V3,W3,AI,BI,CI,AR,BR,GR,S33)

CF = SQRT(S33)

C

C --- CALCULATE ANGLE BETWEEN AF AND BF (GAMMA)

CALL DOT (U1,V1,W1,U2,V2,W2,AI,BI,CI,AR,BR,GR,S12)

COSG = S12/(AF*BF)

GAMF = (ACOS(COSG))*RADIAN

C

C --- CALCULATE ANGLE BETWEEN AF AND CF (BETA)

CALL DOT (U1,V1,W1,U3,V3,W3,AI,BI,CI,AR,BR,GR,S13)

COSB = S13/(AF*CF)

BETF = (ACOS(COSB))*RADIAN

C

C --- CALCULATE ANGLE BETWEEN BF AND CF (ALPHA)

CALL DOT (U2,V2,W2,U3,V3,W3,AI,BI,CI,AR,BR,GR,S23)

COSA = S23/(BF*CF)

ALPF = (ACOS(COSA))*RADIAN

C

C --- CALCULATE VOLUME

VOLF = AF*BF*CF*SQRT(1.0 - COSG**2 - COSB**2 - COSA**2 +

$ 2.0*COSA*COSB*COSG)

C

IF(IPRTRA.EQ.0) GO TO 400

C

C --- WRITE OUTPUT

CALL OUTPT1(11)

CALL INVERS(1)

CALL OUTPT1(13)

C

C --- OPTIONAL WRITE OF REDUCED CELLS ON IUNITD

IF(IPCH.EQ.1) WRITE(IUNITD,6100) AF, BF, CF, ALPF,

$ BETF, GAMF, VOLF

IF(IPCH.EQ.1) NUNK = NUNK + 1

C**

C --- ONLY FOR SPECIAL CHECK RUN, WRITE REDUCED CELL,

C TRANSFORMATION MATRIX FROM INITIAL CELL TO REDUCED

C CELL, PROBLEM SEQUENCE NUMBER ON IUNITD

IF(ICK029.NE.1) GO TO 400

NUNK = NUNK + 1

WRITE(IUNITD,6200) AF,BF,CF,ALPF,BETF,GAMF,

$ U1,V1,W1,U2,V2,W2,U3,V3,W3, NUNK

C*

400 CONTINUE

RETURN

6000 FORMAT(/1X,'*TRANS* ERROR ... Invalid matrix, check determinant.'/

$)

6100 FORMAT(6F10.5,F10.2)

6200 FORMAT(6F10.5,2X,9F7.2,2X,I5)

END