The expanded program below uses in addition from CCSL:
ISPABS and LATABS are LOGICAL FUNCTIONs, and must be so declared. SORTX sorts within arrays in store, so these must be DIMENSIONed.
The following, then, is the larger example main program. It should by now be fairly clear to the reader what the various parts of it are, and how they fit together.
COMPLEX FC,FCALC LOGICAL NOMORE,ISPABS,LATABS DIMENSION H(3),K(3,1000),SINTH(1000),IPNT(1000) COMMON /IOUNIT/LPT,ITI,ITO,IPLO,LUNI,IOUT CHARACTER *1 ISPCE,ISTAR DATA ISPCE,ISTAR/' ','*'/ C CALL PREFIN('GETSF') WRITE (ITO,2002) 2002 FORMAT (' Value of sin theta/lambda max? ') READ (ITI,1000) S 1000 FORMAT (F10.4) CALL SYMOP CALL OPSYM(1) CALL OPSYM(2) CALL RECIP CALL ATOPOS CALL SETFOR CALL SETANI CALL SYMUNI WRITE (LPT,2000) 2000 FORMAT (////' Sorted structure factors - * indicates space', 1 'group absence:'/' No. h k l Mult s', 2' A B FcMod') CALL SETGEN(S) C COMPLAIN AND STOP IF THERE WERE ERRORS IN THE INPUT CALL ERRMES(0,0,' to GETSF') NSUM=0 N=0 1 CALL GETGEN(H,NOMORE) IF (NOMORE) GO TO 2 IF (LATABS(H)) GO TO 1 MULT=MULBOX(H) IF (MULT .EQ. 0) GO TO 1 N=N+1 NSUM=NSUM+MULT SINTH(N)=VCTMOD(0.5,H,2) CALL INDFIX(H,K(1,N)) GO TO 1 C C SORT THE ARRAY IPNT, SO THAT IT POINTS TO THE ELEMENTS C OF SINTH IN SEQUENCE: 2 CALL SORTX(SINTH,IPNT,N) DO 3 I=1,N J=IPNT(I) CALL INDFLO(H,K(1,J)) FC=FCALC(H) A=REAL(FC) B=AIMAG(FC) FCMOD=SQRT(A*A+B*B) IC=ISPCE IF (ISPABS(H)) IC=ISTAR M=MULBOX(H) WRITE (LPT,2001) IC,I,(K(L,J),L=1,3),M,SINTH(J),A,B,FCMOD 2001 FORMAT (' ',A1,I5,2X,3I4,2X,I5,F10.5,3X,3F12.5) 3 CONTINUE WRITE (LPT,100) NSUM,S 100 FORMAT (/' Total number of reflections inside sphere', 1'=',I4/' S max=',F10.4) STOP END
The initial dialogue which has been given as a WRITE and a READ statement for simplicity could be more elegantly rendered as:
CALL ASK('Value of sin theta/lambda max?') CALL RDREAL(S,1,IP,80,IE)
because the routine ASK puts out the given message on the screen, and reads in a line from the keyboard ready for routine RDREAL to read the value of S.
Similarly, the WRITE statement with FORMAT 2000 could be replaced by:
CALL CENTRE(LPT,4,'Sorted structure factors - * indicates '// 1 'space group absence;',80) CALL MESS(LPT,0,' No. h k l Mult s'// 2 ' A B FcMod')