C C FON.FTN C C BE SURE AND CHANGE THE LINE BELOW BEGINNING WITH CALL ASSIGN TO C C DESCRIPTION DATA FOR EACH RECORD C C BYTE INTEGER C 1-20 1-10 NAME OF PERSON C 21-44 11-22 COMPANY NAME OR ADDRESS C 45-50 23-25 PHONE NUMBER C C TASK BUILD WITH THE FOLLOWING OPTIONS C C LIBR=FORRES:RO -- USE ONLY IF YOU HAVE A FORTRAN RESIDENT COMMON REGION C ACTFIL=2 C TASK=...FON C BYTE MASTER(50) BYTE BUF(80) ! BUFFER PICKED UP BY MCR BYTE BUFFER(50) ! PORTION OF BUF WE NEED BYTE PHONE(20) INTEGER MOTHER(3) BYTE SPA BYTE OPT1(3),OPT2(3),OPT3(4) BYTE ZER INTEGER PHON1,PHON2,PHON3,FLAG, END INTEGER REC ! RECORD WHERE THIS NO. WILL BE STORED INTEGER POSI ! SUBROUTINE TO FIND POSITION OF STRING INTEGER ANS ! ANSWER TO QUESTION ABOUT RIGHT NAME INTEGER LEN EQUIVALENCE (MOTHER(1),MASTER(45)) EQUIVALENCE (BUF(5),BUFFER(1)) DATA SPA,ZER/' ','0'/ DATA OPT1(1),OPT1(2)/'I','N'/ DATA OPT2(1),OPT2(2)/'X','X'/ DATA OPT3(1),OPT3(2),OPT3(3)/'C','H','A'/ C C GENERAL TECHNIQUE OF THE PROGRAM C FON IN ! ENTER A NEW NAME INTO DIRECTORY C FON NAME ! GET PHONE NO. FOR THIS NAME C FON XX ! REMOVE A NAME FROM DIRECTORY C FON CHA ! MAKE A CHANGE C C COME HERE TO ENTER NAMES INTO THE DIRECTORY C CALL GETMCR(BUF,IBS) CALL TRIM(BUFFER,50) ! GET RID OF CR AT END OF LINE C C BE SURE AND CHANGE THE LINE BELOW TO REPRESENT YOUR SITUATION. C ALSO MAKE SURE THE DATA FILE IS PRIVILEGED FOR ALL THE WORLD AND THE C DIRECTORY FOR THAT ACCOUNT AS STORED IN THE UIC 0,0 IS PRIVILEGED FOR C ALL THE WORLD C CALL ASSIGN(2,'FON.DAT') CALL FDBSET (2,'OLD','SHARE') DEFINE FILE 2(1000,25,U,NEXT) IF((POSI(BUFFER,OPT1,1).EQ.1).AND.(LEN(BUFFER).EQ.2))GO TO 140 C ! ENTER A NEW NAME IF(POSI(BUFFER,OPT2,1).EQ.1)GO TO 400 ! DELETE A NAME IF((POSI(BUFFER,OPT3,1).EQ.1).AND.(LEN(BUFFER).EQ.3))GO TO 450 C ! MAKE A CHANGE GO TO 350 ! IF GET THIS FAR, ASSUME READING A NAME 10 FORMAT(I4) 20 FORMAT(20A1) C C COME HERE TO INPUT A NAME C 140 WRITE(5,150) ! GET THE NAME 150 FORMAT('$NAME: ') READ(5,20,END=1000)(MASTER(J),J=1,20) IF(MASTER(1).EQ.SPA)GO TO 1000 WRITE(5,160) ! GET THE PHONE NO. 160 FORMAT('$PHONE NO. ') READ(5,165,END=1000)NCHR,PHONE 165 FORMAT(Q,20A1) CALL DEC3(PHON1,PHON2,PHON3,FLAG,PHONE,NCHR) IF(FLAG.GT.2)GO TO 200 ! GAVE AN AREA CODE PHON3=PHON2 ! DIDN'T GIVE AN AREA CODE PHON2=PHON1 PHON1=312 200 IF(FLAG.GT.1)GOTO 210 ! GAVE AN EXCHANGE PHON3=PHONE2 ! DIDN'T GIVE AN EXCHANGE PHON2=791 210 MOTHER(1)=PHON1 MOTHER(2)=PHON2 MOTHER(3)=PHON3 WRITE(5,270) 270 FORMAT('$NAME OF COMPANY: ') READ(5,280,END=1000)(MASTER(J),J=21,43) 280 FORMAT(23A1) WRITE(5,290)(MASTER(J),J=1,20),PHON1,PHON2,PHON3,(MASTER(J), 1 J=21,44) 290 FORMAT(1X,20A1,I5,I4,I5,2X,24A1) 291 FORMAT(1X,20A1,I5,I4,' 0',I3,2X,24A1) 292 FORMAT(1X,20A1,' ',I4,I5,2X,24A1) 293 FORMAT(1X,20A1,' ',I4,' 0',I3,2X,24A1) 294 FORMAT(1X,20A1,' ',I5,2X,24A1) 295 FORMAT(1X,20A1,' ',' 0',I3,2X,24A1) IF(ANS.EQ.1)GO TO 500 ! WE WERE JUST MAKING A CHANGE READ(2'1)REC ! GET THE NEXT AVAILABLE REC WRITE(2'REC)MASTER ! WRITE THIS RECORD WRITE(5,300)REC 300 FORMAT(' RESULTS STORED IN RECORD # ',I4) REC=REC+1 WRITE(2'1)REC GO TO 140 C C COME HERE TO READ A PHONE NUMBER C 350 WRITE(5,355) ! DO ONE LINE FEED 355 FORMAT(' ') READ(2'1)REC DO 380 I=2,REC-1 READ(2'I)MASTER CALL TRIM(MASTER,44) IF(POSI(MASTER,BUFFER,1,44).EQ.0)GO TO 380 IF (MOTHER(1).EQ.312.OR.MOTHER(1).LT.100) GOTO 360 C LIST INCLUDING AREA CODE IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) GOTO 380 C LIST WITHOUT AREA CODE 360 IF (MOTHER(2).LT.100.OR.MOTHER(2).EQ.791) GOTO 370 IF (MOTHER(3).GT.999) WRITE(5,292)(MASTER(J),J=1,20), 1(MOTHER(J),J=2,3),(MASTER(J),J=21,44) IF (MOTHER(3).LE.999) WRITE(5,293)(MASTER(J),J=1,20), 1(MOTHER(J),J=2,3),(MASTER(J),J=21,44) GOTO 380 C LIST IN-HOUSE 4-DIGIT NUMBER 370 IF (MOTHER(3).GT.999) WRITE(5,294)(MASTER(J),J=1,20), 1MOTHER(3),(MASTER(J),J=21,44) IF (MOTHER(3).LE.999) WRITE(5,295)(MASTER(J),J=1,20), 1MOTHER(3),(MASTER(J),J=21,44) 380 CONTINUE GO TO 1000 C C COME HERE TO THROW OUT THIS LIST OF NAMES AND START OVER C 400 WRITE(5,405) 405 FORMAT(/,'$WHAT IS THE NAME YOU WANT TO DELETE ') READ(5,465,END=1000)BUFFER IF(BUFFER(1).EQ.SPA)GO TO 1000 CALL TRIM(BUFFER,50) ! GET RID OF TRAILING BLANKS READ(2'1)END END=END-1 DO 420 I=2,END READ(2'I)MASTER IF(POSI(MASTER, BUFFER, 1, 44).EQ.0) GO TO 420 ! NO MATCH FOUND IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) WRITE(5,471)I ! ASK IF THIS IS RIGHT ONE WRITE(5,470) READ(5,10,END=1000)ANS IF(ANS.EQ.1) GO TO 430 420 CONTINUE WRITE(5,490) GO TO 400 430 IF(I.GE.END) GO TO 445 DO 440 J=I+1,END READ(2'J)MASTER WRITE(2'J-1)MASTER 440 CONTINUE 445 WRITE(2'1)END ! END IS 1 LESS NOW, STORE IT GO TO 400 C C COME HERE TO MAKE A CHANGE C 450 WRITE(5,460) 460 FORMAT(/,'$WHAT NAME DO YOU WANT TO CHANGE ') READ(5,465,END=1000)BUFFER 465 FORMAT(50A1) IF(BUFFER(1).EQ.SPA)GO TO 1000 ! ENTERED A BLANK CALL TRIM (BUFFER,50) ! GET RID OF TRAILING BLANKS READ(2'1)END DO 480 I=2,END-1 READ(2'I)MASTER IF(POSI(MASTER,BUFFER,1,44).EQ.0)GO TO 480 IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20), 1(MOTHER(J),J=1,3),(MASTER(J),J=21,44) WRITE(5,471)I 471 FORMAT(' REC ',I4) WRITE(5,470) 470 FORMAT('$IF THIS IS THE RIGHT ENTRY, ENTER 1: ') READ(5,10,END=1000)ANS ! GET THEIR ANSWER IF(ANS.NE.1)GO TO 480 ! THIS WASN'T RIGHT ONE CALL LOA(MASTER,50,0) ! ERASE WHAT WAS THERE GO TO 140 480 CONTINUE WRITE(5,490) 490 FORMAT(' FAILED TO FIND THIS NAME') GO TO 450 500 WRITE(2'I)MASTER ! STORE THE RESULTS WRITE(5,510)I 510 FORMAT(' WRITTEN IN REC ',I4) GO TO 450 1000 CALL CLOSE(2) CALL EXIT END