SUBROUTINE KBFFWC(SYSFIL,BALFIL,BNDFIL,OUTFIL, 1 ERRCD,ERRMSG) C C FUNCTION: CF CF C USAGE: CU CU C INPUTS: CI CI C OUTPUTS: CO CO C ALGORITHM: CA CA C MACHINE DEPENDENCIES: CM CM C HISTORY: CH CH written by: CH date: CH current version: CH modifications: CH added dpcom: 7/16/88 jdb CH corrected real,cmplx: 7/27/88 jdb CH C ROUTINES CALLED: CC CC C COMMON MEMORY USED: CM CM DPCOM -- see dpcommon.f and dpcom.f CM C---------------------------------------------------------------------- C written for: The CASCADE Project C Oak Ridge National Laboratory C U.S. Department of Energy C contract number DE-AC05-840R21400 C subcontract number 37B-07685C S13 C organization: The University of Tennessee C---------------------------------------------------------------------- C THIS SOFTWARE IS IN THE PUBLIC DOMAIN C NO RESTRICTIONS ON ITS USE ARE IMPLIED C---------------------------------------------------------------------- C C INCLUDE 'Parameter.f' C CHARACTER*(*) SYSFIL CHARACTER*(*) BALFIL CHARACTER*(*) BNDFIL CHARACTER*(*) OUTFIL CHARACTER*(*) ERRMSG C DOUBLE PRECISION A(SIZE,SIZE) DOUBLE PRECISION B(SIZE,SIZE) DOUBLE PRECISION C(SIZE,SIZE) DOUBLE PRECISION DD(SIZE,SIZE) DOUBLE COMPLEX P(SIZE,SIZE) DOUBLE COMPLEX W(SIZE) DOUBLE COMPLEX RV1(SIZE) DOUBLE PRECISION D(SIZE,SIZE) DOUBLE COMPLEX U(SIZE,SIZE) DOUBLE COMPLEX V(SIZE,SIZE) DOUBLE PRECISION SIGMAX DOUBLE PRECISION SIGMIN DOUBLE COMPLEX WORK(SIZE) DOUBLE PRECISION MNOMXP DOUBLE PRECISION BOUND DOUBLE PRECISION FREQ DOUBLE PRECISION WCMIN DOUBLE COMPLEX CP(SIZE,SIZE) DOUBLE PRECISION X,Y C DOUBLE PRECISION DREAL DOUBLE COMPLEX DCMPLX C INTEGER NBNDL INTEGER NSTATS INTEGER NINPS INTEGER NOUTS INTEGER ERRCD INTEGER IERR C INCLUDE 'dpcom.f' C ERRCD=0 C OPEN (UNIT=UNIT8,FILE=BNDFIL,STATUS='OLD',ERR=9999) READ (UNIT8,*,END=9999,ERR=9999) X,Y READ (UNIT8,*,END=9999,ERR=9999) NBNDL READ (UNIT8,*,END=9999,ERR=9999) BOUND,FREQ WCMIN = 10.0D0 ** (BOUND/20.0D0) * FREQ NBNDL = NBNDL - 1 10 IF (NBNDL .GT. 0) THEN READ (UNIT8,*,END=9999,ERR=9999) BOUND,FREQ WCMIN = MIN (WCMIN,10.0D0 ** (BOUND/20.0D0) * FREQ) NBNDL = NBNDL - 1 GO TO 10 END IF CLOSE(UNIT=UNIT8) C CALL INSYS (SYSFIL,NINPS,NOUTS,NSTATS, 2 SIZE,SIZE,SIZE,A,B,C,DD,ERRCD) CLOSE (UNIT=UNIT1) IF (ERRCD .NE. 0) THEN ERRMSG = 'KBFFWC: Fatal error from INSYS '// 1 'accessing '//SYSFIL RETURN END IF C OPEN (UNIT=UNIT8,FILE=BALFIL,STATUS='OLD',ERR=9998) C DO 20, I = 1, NSTATS READ (UNIT8,*,ERR=9998) (P(I,J),J=1, NOUTS) 20 CONTINUE C DO 30, I = 1, NSTATS READ (UNIT8,*,ERR=9998) (D(I,J),J=1, NSTATS) 30 CONTINUE C CLOSE (UNIT=UNIT8) C C--now find maximum singular value at crossover to determine mu C DO 33 I = 1, NOUTS DO 32 J = 1, NOUTS CP(J,I) = DCMPLX(0.0D0,0.0D0) DO 31 K = 1, NSTATS CP(J,I) = CP(J,I) + C(J,K)*P(K,I) 31 CONTINUE 32 CONTINUE 33 CONTINUE C C CALL MMUL (SIZE,SIZE,SIZE,NOUTS,NSTATS,NOUTS,C,P,CP) C CALL SVD (SIZE,NOUTS,NOUTS,CP,W,.FALSE., C 2 U,.FALSE.,V,IERR,RV1) CALL ZSVDC(CP,SIZE,NOUTS,NOUTS,W,RV1,U,SIZE,V,SIZE, 1 WORK,0,IERR) IF (IERR.NE.0) THEN ERRCD = 100 + IERR ERRMSG = 'KBFFWC: Fatal error returned '// 1 'from DSVDC. ERRCD = 100 + INFO, where '// 2 'INFO is returned from DSVDC.' RETURN END IF SIGMAX = DREAL(W(1)) SIGMIN = DREAL(W(1)) DO 71 I = 1, NOUTS IF (DREAL(W(I)) .LT. 1.D-10) GO TO 71 IF (SIGMAX .LT. DREAL(W(I))) SIGMAX = DREAL(W(I)) IF (SIGMIN .GT. DREAL(W(I))) SIGMIN = DREAL(W(I)) 71 CONTINUE IF (SIGMIN .LT. 1.D-10) THEN MNOMXP = 1.0D0 ELSE MNOMXP = SIGMIN / SIGMAX END IF C OPEN (UNIT=UNIT8,FILE=OUTFIL,ERR=9997) C WRITE (UNIT8,*,ERR=9997) WCMIN, SIGMAX, MNOMXP C CLOSE (UNIT=UNIT8) C C-- THE END C RETURN C C--ERROR HANDLING C 9997 ERRCD = 3 ERRMSG = 'KBFFWC: Fatal error accessing output '// 1 'file '//OUTFIL 9998 ERRCD = 2 ERRMSG = 'KBFFWC: Fatal error accessing balancing '// 1 'file '//BALFIL 9999 ERRCD = 1 ERRMSG='KBFFWC: Fatal error; Something wrong '// 1 'with the bounds file '//BNDFIL CLOSE (UNIT=UNIT8) RETURN END