SUBROUTINE ld_weights(success) IMPLICIT NONE LOGICAL success REAL*8 lam0, lam1, w0, w1 REAL*8 f INTEGER*4 ilam0, ilam1, j, ilamseek INTEGER*4 wl_lun, wf_lun, istart, ilam CHARACTER*80 weightfile INCLUDE "params.inc" INCLUDE "rttbls_cs.cmn" INCLUDE "weights.cmn" WRITE(6,*)'Loading spectral weighting functions...' WRITE(loglun,*)'Loading spectral weighting functions...' n_w_fns= 0 j= -1 n_w_knots= -1 c------------------------------------------------------------------- c Open list of spectral weighting function files. c CALL get_lun(wl_lun) CALL get_lun(wf_lun) OPEN(UNIT=wl_lun, & FILE='WEIGHTLIST', & FORM='formatted', & STATUS='old', & ERR=900) c------------------------------------------------------------------- c Loop through the entries in the list, open the files listed. c 100 CONTINUE READ(wl_lun,1,END=200,ERR=901)weightfile IF(weightfile(1:1) .EQ. ' ') GOTO 100 WRITE(loglun,*)' ',weightfile(1:70) OPEN(UNIT=wf_lun, & FILE=weightfile, & FORM='formatted', & STATUS='old', & ERR=909) c------------------------------------------------------------------- c Read through the files and build the weighting functions, c First record (up to 10 characters) is the name of the function (e.g. c wavelength or action spectrum name) c First weight must be zero at some wavelength. c READ(wf_lun,2) w_name(n_w_fns) READ(wf_lun,*) lam0, w0 IF (w0 .NE. 0.d0) GOTO 902 ilam0= ilamseek(lam0, waveln, n_waveln) w_ix0(n_w_fns)= j + 1 w_ilam0(n_w_fns)= ilam0+1 w_zero0(n_w_fns)= lam0 istart=1 110 CONTINUE READ(wf_lun,*,END=120) lam1, w1 IF(lam1 .LT. lam0) GOTO 905 IF(lam1 .LT. waveln(0)) GOTO 903 IF(lam0 .GT. waveln(n_waveln-1)) GOTO 904 n_w_knots= n_w_knots + 1 IF(n_w_knots .EQ. max_w_knots) GOTO 908 w_knot_wt(n_w_knots)= w1 ilam1= ilamseek(lam1, waveln, n_waveln) f= (w1 - w0)/(lam1 - lam0) DO ilam= ilam0+istart, ilam1 j=j+1 IF(j .EQ. max_weights) GOTO 906 weight(j)= w0 + f*(waveln(ilam) - lam0) END DO lam0= lam1 ilam0= ilam1 w0= w1 istart=1 GOTO 110 120 CONTINUE c------------------------------------------------------------------- c Make sure last weight read was zero. c IF (w0 .NE. 0.d0) GOTO 907 w_zero1(n_w_fns)= lam0 n_w_fns= n_w_fns + 1 c------------------------------------------------------------------- c Go on to next file c CLOSE(wf_lun) GOTO 100 c------------------------------------------------------------------- c All done. Close the list file, set the last pointer in w_ix0, c and blow out of here. 200 CONTINUE CLOSE(wl_lun) CALL unget_lun(wl_lun) CALL unget_lun(wf_lun) w_ix0(n_w_fns)= j + 1 success= .TRUE. c------------------------------------------------------------------------ c Optional diagnostic output. c d CALL get_lun(diag_lun) d OPEN(UNIT=diag_lun, FILE='ld_weights.diagnostics', d FORM='formatted') d WRITE(diaglun,701) max_weights, max_w_fns, max_w_knots, n_w_fns d 701 FORMAT('Weight function common block diagnostic file.'// d & 'Parameters:'/ d & t10,'maximum weight points (max_weights)',t60,i6/ d & t10,'maximum weight functions (max_w_fns)',t60,i6/ d & t10,'maximun weight knots (max_w_knots)',t60,i6/) d DO i_w_fn= 0, n_w_fns-1 d WRITE(diaglun,702) i_w_fn, w_ix0(i_w_fn), w_zero0(i_w_fn), d & w_zero1(i_w_fn), w_ilam0(i_w_fn), d & waveln(w_ilam0(i_w_fn)), weight(w_ix0(i_w_fn)) d DO ix= w_ix0(i_w_fn)+1, w_ix0(i_w_fn+1)-1 d WRITE(diaglun,703) d END DO d CALL unget_lun(diaglun) c------------------------------------------------------------------------ RETURN c------------------------------------------------------------------- c Error handling. c 900 CONTINUE WRITE(6,*)' Can''t open the WEIGHTLIST file.' GOTO 999 901 CONTINUE WRITE(6,*)' Error reading the WEIGHTLIST file.' GOTO 999 902 CONTINUE WRITE(6,*)' The first weight in the weight function file ', & 'must be zero.' GOTO 999 903 CONTINUE WRITE(6,*)' All wavelengths in this file are less than ', & 'the wavelengths in the table.' WRITE(6,*)' Wavelengths must be in the range ',waveln(0), & ' to ',waveln(n_waveln-1) GOTO 999 904 CONTINUE WRITE(6,*)' An entire wavelength interval in the weight file' WRITE(6,*)' is to the left of the wavelength interval in the' WRITE(6,*)' continuous scan tables.' WRITE(6,*)' Wavelengths must be in the range ',waveln(0), & ' to ',waveln(n_waveln-1) GOTO 999 905 CONTINUE WRITE(6,*)' An entire wavelength interval in the weight file' WRITE(6,*)' is to the right of the wavelength interval in the' WRITE(6,*)' continuous scan tables.' WRITE(6,*)' Wavelengths must be in the range ',waveln(0), & ' to ',waveln(n_waveln-1) GOTO 999 906 CONTINUE WRITE(6,*)' Maximum number of weights was exceeded.' GOTO 999 907 CONTINUE WRITE(6,*)' The last weight in the weight function file ', & 'must be zero.' GOTO 999 908 CONTINUE WRITE(6,*)' Maxumum number of weight function knots was exceeded' GOTO 999 909 CONTINUE WRITE(6,*)' Error while opening the weight function file.' GOTO 999 999 success= .FALSE. RETURN 1 FORMAT(A) 2 FORMAT(A10) END FUNCTION ilamseek(lam, waveln, n_waveln) INTEGER*4 ilamseek INTEGER*4 n_waveln REAL*8 lam, waveln(0:n_waveln-1) INTEGER*4 ilam c--See if we've fallen off the low end IF(lam .LE. waveln(0)) THEN ilamseek= 0 RETURN ENDIF c--See if we've fallen off the high end IF(lam .GE. waveln(n_waveln-1)) THEN ilamseek= n_waveln-1 RETURN ENDIF c--First guess ilam= INT((lam-waveln(0))*n_waveln/(waveln(n_waveln-1)-waveln(0))) IF(ilam .GE. n_waveln-1) ilam= n_waveln-2 101 CONTINUE IF((lam .GE. waveln(ilam )) .AND. & (lam .LT. waveln(ilam+1))) GOTO 102 IF((lam .LT. waveln(ilam)) .AND. & (ilam .EQ. 0)) GOTO 102 IF((lam .GE. waveln(ilam)) .AND. & (ilam .EQ. waveln(n_waveln-2))) GOTO 102 IF(lam .LT. waveln(ilam )) ilam= ilam - 1 IF(lam .GE. waveln(ilam+1)) ilam= ilam + 1 GOTO 101 102 CONTINUE ilamseek=ilam RETURN END