SUBROUTINE ERROR(NOR,LEN) USE Numeric_Kinds_Module SAVE ! ! $RCSfile: error.f,v $ $Revision: 1.3 $ ! $Date: 89/07/28 09:57:09 $ ! $State: Stable $ ! ! ! ********************************************************************** ! ! PURPOSE - ! ! ERROR HANDLING. THE FIRST TIME ERROR IS CALLED AN ERROR ! MESSAGE IS WRITTEN. ON THE SECOND CALL A HEADING IS WRITTEN. ! THE REMAINING CALLS GIVE A TRACEBACK. ! ! ! INPUT PARAMETERS - ! ! NOR = NUMBER OF THE CALLING ROUTINE. ! LEN = LOCAL ERROR NUMBER IN THAT ROUTINE (ONLY USED IN ! THE FIRST CALL). ! ! ********************************************************************** ! REAL(Kind=WP_Kind) ALTMU, MU, NEXTMU, OLDMU, RDUMP, TIME, SMALL INTEGER CNEG, COUNT, CPOS, DUMMY, ENOR, ERRNO, IDUMP, ITERNO, LEN, MSGLVL, N, NBADMU, NMXRST, NOR, OLCPOS, P, REST, & RNEW, ROLD, TCONV, TL, TN, NERR , NOUT , UNOR, VER LOGICAL FIRST, USEMX, ZERBET COMMON /STLMCT/ N, ITERNO, TCONV, CNEG, CPOS, OLCPOS, RNEW, ROLD, REST, P, USEMX, ZERBET COMMON /STLMER/ RDUMP, ERRNO, IDUMP(2) COMMON /STLMMU/ MU, OLDMU, NEXTMU, ALTMU COMMON /STLMPR/ MSGLVL, NERR , NOUT COMMON /STLMST/ TIME(24), COUNT(24), NBADMU, NMXRST, DUMMY COMMON /STLMVR/ SMALL, VER ! DATA ENOR /4/ ! COUNT(ENOR)=COUNT(ENOR)+1 IF(COUNT(ENOR) == 2)RETURN TN=NOR TL=LEN ! ! ********************************************* ! CHECK IF LEN LIES IN THE CORRECT INTERVAL. ! ********************************************* IF(TL <= 0 .OR. TL > 99) TL=0 FIRST=COUNT(ENOR) == 1 IF(.NOT. FIRST) GOTO 5 ! ************************* ! COMPUTE THE ERROR NUMBER. ! ************************* ERRNO=100*TN+TL 5 IF(MSGLVL == 0)RETURN ! IF(.NOT. FIRST) GOTO 15 ! ****************** ! WRITE THE HEADING. ! ****************** IF(MSGLVL <= 3) WRITE(NERR ,10) 10 FORMAT(/////1X,60("*"),2(/1X,"*",58X,"*")/1X,"*",10X, & "E R R O R I N S T L M P A C K A G E", 10X, & "*",2(/1X,"*",58X,"*")/1X,60("*")) ! IF(MSGLVL == 4) WRITE(NERR ,11) 11 FORMAT(//1///1X,120("*")/1X,120("*")/1X, & 120("*")/ 2(1X,"***",114X,"***"/),1X,"***", & 38X,"E R R O R I N S T L M P A C K A G E",38X, & "***" /2(1X,"***",114X,"***"/),1X,120("*")/1X,120("*")/ 1X,120("*")) ! WRITE(NERR ,12) ERRNO,NOR,LEN 12 FORMAT(//4X,"ERRNO =",I18/4X,"NOR =",I18/ 4X,"LEN =", & I18//4X,"HERROR OCCURRED IN") ! ! **************************** ! WRITE THE TRACEBACK HEADING. ! **************************** 15 IF(COUNT(ENOR) == 3) WRITE(NERR ,20) 20 FORMAT(/4X,"TRACEBACK"/4X,9("-")) ! IF(.NOT. TN == 0) GOTO 40 WRITE(NERR ,30) 30 FORMAT(4X,"***** UNKNOWN") RETURN ! ! ************************************************** ! WRITE INFORMATION FOR THE ROUTINE WITH NUMBER NOR. ! AN ERROR MESSAGE OR THE ROUTINE NAME IS WRITTEN. ! ************************************************** 40 IF(NOR >= 100) GOTO 5000 !GOTO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300, 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,9999,2500), NOR ! IF(NOR==1)THEN 100 WRITE(NERR ,110) 110 FORMAT(4X,"ALLOC") IF(.NOT. FIRST)RETURN WRITE(NERR ,120) IDUMP 120 FORMAT(4X,"ALL WORKING VECTORS OCCUPIED"/ 4X,"ID =",I18/4X,"ACTION =",I18) ELSEIF(NOR==2)THEN ! 200 WRITE(NERR ,210) 210 FORMAT(4X,"ALWAYS") IF(.NOT. FIRST)RETURN IF(LEN == 1) WRITE(NERR ,220) RDUMP IF(LEN == 2) WRITE(NERR ,230) REST IF(LEN == 3) WRITE(NERR ,240) IF(LEN == 3) WRITE(NERR ,250) IF(LEN == 4) WRITE(NERR ,260) IF(LEN == 4) WRITE(NERR ,240) IF(LEN == 4) WRITE(NERR ,270) REST 220 FORMAT(4X,"THE M-MATRIX IS PRESUMABLY INDEFINITE."/ 4X,"DOT =",ES18.7) 230 FORMAT(4X,"REST IS NEGATIVE./4X,8HREST =",I18) 240 FORMAT(4X,"CAN NOT COMPUTE A NEW SHIFT.") 250 FORMAT(4X,"CNEG PAIRS ARE STORED.") 260 FORMAT(4X,"REST IS POSITIVE AND") 270 FORMAT(4X,"CNEG PAIRS ARE NOT STORED."/4X,"REST =",I18) ELSEIF(NOR==3)THEN ! 300 WRITE(NERR ,310) 310 FORMAT(4X,"DECOMP") IF(.NOT. FIRST)RETURN IF(.NOT. LEN == 1) GOTO 330 WRITE(NERR ,350) MU IF(.NOT. IDUMP(2) == 1)RETURN WRITE(NERR ,370) RDUMP,IDUMP(1) RETURN 330 WRITE(NERR ,380) MU,REST RETURN 350 FORMAT(4X,'LDLT FAILED FOR TWO CONSECUTIVE SHIFTS.'/ 4X,'MU =',ES18.7) 370 FORMAT(4X,'RDUMP =',ES18.7/4X,'I =',I18) 380 FORMAT(4X,'REST GREATER THAN MXREST FOR TWO CONSECUTIVE SHIFTS.'/ 4X,'MU =',ES18.7/4X,'REST =',I18) ELSEIF(NOR==4)THEN 400 RETURN ELSEIF(NOR==5)THEN 500 WRITE(NERR ,510) 510 FORMAT(4X,"FRSTIT") IF(.NOT. FIRST)RETURN WRITE(NERR ,520) MU 520 FORMAT(4X,'FIRST SHIFT GREATER THAN LAMBDA(N). '/4X,'MU =',ES18.7) ELSEIF(NOR==6)THEN 600 WRITE(NERR ,610) 610 FORMAT(4X,"IMTQL2") IF(.NOT. FIRST)RETURN WRITE(NERR ,620) IDUMP(1) 620 FORMAT(4X,"MORE THEN 30 ITERATIONS ARE REQUIRED TO "/4X,"DETERMINE NU-EIGENVALUE NUMBER",I10) ELSEIF(NOR==7)THEN 700 WRITE(NERR ,710) 710 FORMAT(4X,"INITLA") ELSEIF(NOR==8)THEN 800 WRITE(NERR ,810) 810 FORMAT(4X,"INITU") ELSEIF(NOR==9)THEN 900 WRITE(NERR ,910) 910 FORMAT(4X,"IO") IF(.NOT. FIRST)RETURN IF(LEN == 1) WRITE(NERR , 920) 920 FORMAT(4X,"DAFILE IS FULL.") IF(LEN == 2) WRITE(NERR , 930) IDUMP(1) 930 FORMAT(4X,"TRIED TO READ RECORD =", I6) IF(LEN == 3) WRITE(NERR , 940) IDUMP(1) 940 FORMAT(4X,"TRIED TO WRITE RECORD =", I6) ELSEIF(NOR==10)THEN 1000 WRITE(NERR ,1010) 1010 FORMAT(4X,"LANCZO") IF(.NOT. FIRST)RETURN WRITE(NERR ,220) RDUMP ELSEIF(NOR==11)THEN 1100 WRITE(NERR ,1110) 1110 FORMAT(4X,"LDLT") ELSEIF(NOR==12)THEN 1200 WRITE(NERR ,1210) 1210 FORMAT(4X,"MULVEC") ELSEIF(NOR==13)THEN 1300 WRITE(NERR ,1310) 1310 FORMAT(4X,"OPINV") ELSEIF(NOR==14)THEN 1400 WRITE(NERR ,1410) 1410 FORMAT(4X,"OPM") ELSEIF(NOR==15)THEN 1500 WRITE(NERR ,1510) 1510 FORMAT(4X,"PREPSV") ELSEIF(NOR==16)THEN 1600 WRITE(NERR ,1610) 1610 FORMAT(4X,"RANDVC") ELSEIF(NOR==17)THEN 1700 WRITE(NERR ,1710) 1710 FORMAT(4X,"SAVEXL") IF(.NOT. FIRST)RETURN WRITE(NERR, 1720) RDUMP 1720 FORMAT(4X,"INSUFFICIENT STORAGE TO STORE AN EIGENVALUE."/ 4X,"LAMBDA =", ES18.7) ELSEIF(NOR==18)THEN 1800 WRITE(NERR ,1810) 1810 FORMAT(4X,"SCPROD") ELSEIF(NOR==19)THEN 1900 WRITE(NERR ,1910) 1910 FORMAT(4X,"SELDOM") IF(.NOT. FIRST)RETURN IF(LEN == 1) WRITE(NERR ,220) RDUMP IF(LEN == 2) WRITE(NERR ,1920) REST IF(LEN == 3) WRITE(NERR ,230) REST 1920 FORMAT(4X,"EIGENPAIRS ARE MISSING, BUT NO CONVERGENCE."/ 4X,"REST =",I18) ELSEIF(NOR==20)THEN 2000 WRITE(NERR ,2010) 2010 FORMAT(4X,"STLM"//4X,"TRACEBACK COMPLETED."/// 1X,"*** ERROR ***") ELSEIF(NOR==21)THEN 2100 WRITE(NERR ,2110) 2110 FORMAT(4X,"SUBVEC") ELSEIF(NOR==22)THEN 2200 WRITE(NERR ,2210) 2210 FORMAT(4X,"TRANSF") ELSEIF(NOR==23)THEN 2300 WRITE(NERR ,2310) 2310 FORMAT(4X,"TRIDIG") ELSEIF(NOR==24)THEN RETURN ELSEIF(NOR==25)THEN 2500 WRITE(NERR , 2510) 2510 FORMAT(4X,"INITD") ENDIF IF(.NOT. FIRST)RETURN IF(LEN == 1) WRITE(NERR , 2515) 2515 FORMAT(4X, "ILLEGAL VER.") IF(LEN == 2) WRITE(NERR , 2520) 2520 FORMAT(4X, "N LESS EQUAL 0.") IF(LEN == 3) WRITE(NERR , 2525) 2525 FORMAT(4X, "ILLEGAL PROFIL.") IF(LEN == 4) WRITE(NERR , 2530) 2530 FORMAT(4X, "MAXL LESS EQUAL 0.") IF(LEN == 5) WRITE(NERR , 2535) 2535 FORMAT(4X, "MAXREC LESS EQUAL 0.") IF(LEN == 6) WRITE(NERR , 2540) IDUMP(1) 2540 FORMAT(4X, "ERROR IN D.", I10) IF(LEN == 7) WRITE(NERR , 2545) IDUMP(1) 2545 FORMAT(4X, "ERROR IN M., I10") IF(LEN == 8) WRITE(NERR , 2550) 2550 FORMAT(4X, "ILLEGAL MSGLVL.") IF(LEN == 9) WRITE(NERR , 2555) 2555 FORMAT(4X, "ILLEGAL PMAX.") IF(LEN == 10) WRITE(NERR , 2560) 2560 FORMAT(4X, "TOO SMALL MAXW.") IF(LEN == 11) WRITE(NERR , 2565) 2565 FORMAT(4X, "TOO SMALL MAXIW.") IF(LEN == 12) WRITE(NERR , 2570) 2570 FORMAT(4X, "B LESS EQUAL A.") IF(LEN == 13) WRITE(NERR , 2575) 2575 FORMAT(4X, "ILLEGAL FILE UNITS.") RETURN ! ! *********** ! USER CALLS. ! *********** 5000 UNOR = NOR - 99 IF(.NOT. FIRST)RETURN IF(UNOR==1)THEN 5100 WRITE(NERR , 5110) VER 5110 FORMAT(4X, "LDL", I1) ELSEIF(UNOR==2)THEN 5200 WRITE(NERR , 5210) VER 5210 FORMAT(4X, "OPM", I1) ELSEIF(UNOR==3)THEN 5300 WRITE(NERR , 5310) VER 5310 FORMAT(4X, "SOL", I1) ELSEIF(UNOR==4)THEN 5400 WRITE(NERR , 5410) VER 5410 FORMAT(4X, "MUL", I1) ELSEIF(UNOR==5)THEN 5500 WRITE(NERR , 5510) VER 5510 FORMAT(4X, "RAN", I1) ELSEIF(UNOR==6)THEN 5600 WRITE(NERR , 5610) VER 5610 FORMAT(4X, "SCP", I1) ELSEIF(UNOR==7)THEN 5700 WRITE(NERR , 5710) VER 5710 FORMAT(4X, "SUB", I1) ENDIF ! 9999 RETURN END