C This program reads four matrices from nastran binary output files C created with the OUTPUT4 module in the MSC Nastran DDAM DMAP alters. C The four matrices read are: OMEGX (natural frequencies) C PAB (participation factors) C MTOT (total mass in each direction) C MFRACT(% of total mass from modes used) C C The program calculates the loads from the modal masses and the data C read from a data file that the user creates. It then writes the C loads to a NASTRAN readable binary file which the DDAM DMAP alters C read via the INPUT4 module. Provisions are made to allow shuffling C of the input coefficients for non-standard axis systems (x:f/a,y:a, C and z:v is MY standard) C C Program written by MSC NASTRAN personel and transferred to NKF 12/86 C Modified 3/87 by BMW to include: C improved format of .VER file C ability to use user input shock spectrum C Modified 6/90 by RDM to work with Cosmic Nastran C (user input spectrum routine deleted) C Modified 6/91 by RDM to work with CSAR Nastran C Modified 10/96 by BWM to work with MSC/NASTRAN v.68 c added user input spectrum c changed coefficient formats and variables c added single mode capability C subroutine ddam(ddambatch,usercoef,userspec,standard, + filecoef,filespec,filein,fileout,filever,axes, + prefp, + nsurf,nstruc,nplast) parameter (maxmodes=300) parameter (maxlines=1000000) parameter (maxpoints=1000) REAL OMEG(maxmodes), PARTIC(maxmodes,6), MTOT(6,1), MFRACT(6,1) REAL aspec(maxpoints,2,3) INTEGER numpoints(3) REAL OVF(2,3,2,3),OAF(2,3,2,3) REAL AA(2,3,2),AB(2,3,2),AC(2,3,2),AD(2,3,2) REAL VA(2,3,2),VB(2,3,2),VC(2,3,2) CHARACTER*5 OUTNAME(3) CHARACTER*8 INNAME(4),PNUM CHARACTER*20 NAMEP CHARACTER*24 NAMEP1 CHARACTER*40 filein, fileout,filever CHARACTER*40 filespec, filecoef CHARACTER*1 axes(2) LOGICAL surface, submarine, deck, hull, shell LOGICAL elastic, plastic LOGICAL userspec, usercoef, standard LOGICAL true, false LOGICAL ddambatch LOGICAL logfreq, logdisp REAL PREF, PREFP REAL TOLERANCE DIMENSION MMAX(6), FRSS(6), * GNAV(6), AM(maxmodes), PB(maxmodes), W(maxmodes), * UHV(maxmodes,3,3), * UHVX(maxmodes,3),UHVY(maxmodes,3),UHVZ(maxmodes,3), * FMAX(6), WTOTP(maxmodes), * WPERC(maxmodes), NDIRA(3) DATA TWOPI/6.2831853/, GRAV/386.4/ DATA INNAME/'OMEGX ','PAB ','MTOT ','MFRACT '/, * OUTNAME/'UHVRX','UHVRY','UHVRZ'/ true = .TRUE. false = .FALSE. tolerance = 1.E-3 ioinp = 11 ioout = 12 iocoef = 13 iospec = 14 iover = 15 c ... set up default values for the coefficients call set_default_coef( + ovf,oaf, + va,vb,vc,aa,ab,ac,ad, + pref) surface = false submarine = false deck = false hull = false shell = false elastic = false plastic = false c ... optain the file names of the input and output files CALL MENU1(ddambatch,ioinp,ioout,iocoef,iospec,iover, + usercoef,userspec,NAMEP,NAMEP1, + filein,fileout,filever,filecoef,filespec) c ... if using an external coefficient file, read it IF ( usercoef ) THEN CALL LDCOEF(iocoef,maxlines, + ovf,oaf, + va,vb,vc,aa,ab,ac,ad, + pref, + surface, submarine, deck, hull, shell, elastic, plastic) ENDIF c ... if running a user spectrum, read it into the aspec variable if (userspec) then call readinp(maxlines,maxpoints,iospec,aspec,numpoints, + logfreq,logdisp) else c ... determine the loading parameters for location and ship type IF (.NOT. ddambatch) then CALL MENU2(NSURF,NSTRUC,NPLAST, + surface,submarine,deck,hull,shell,elastic,plastic) ENDIF endif c ... make sure the axes are arranged correctly CALL MENU3(ddambatch,axes,NDIRA) c ... provide option to do a single mode rather than all modes IF (.NOT. ddambatch) then write(6,*) ' Is this a multiple or single mode analysis ?' write(6,*) ' = normal, s = single mode' read(5,'(a)') pnum ll = length(pnum) if (ll .eq. 0) then standard = true else write(6,*) ' What mode number do you want to look at ?' read(5,*) target standard = false pref = 100. endif ENDIF c ... if a multiple mode analysis (conventional DDAM) find the c mass cutoff percentage if (standard) then IF (ddambatch) THEN if (prefp .gt. tolerance) then PREF = PREFP endif ELSE WRITE(6,*) 'ENTER WEIGHT CUTOFF PERCENT OR FOR DEFAULT:' WRITE(6,'(a,f5.1)') ' Default = ',pref READ(5,'(a)') PNUM LL=LENGTH(PNUM) IF (LL .NE. 0) THEN READ(PNUM,*) PREF ENDIF ENDIF endif c ... get the matrices from the NASTRAN OUTPUT4 file c ... MSC uses the RDNAS subroutine NR= maxmodes NC=1 CALL RDNAS(INNAME(1),OMEG,NR,NC,'BINARY',ioinp) MODES= NR NR= maxmodes NC= 6 CALL RDNAS(INNAME(2),PARTIC,NR,NC,'BINARY',ioinp) C added to allow printing of percentages of modal mass NR=6 NC=1 CALL RDNAS(INNAME(3),MTOT,NR,NC,'BINARY',ioinp) CALL RDNAS(INNAME(4),MFRACT,NR,NC,'BINARY',ioinp) c ... start doing stuff ... DO 30 NDIR= 1, 3 C NDIR changed to NDIRA(NDIR) to allow for other axes if (.not. userspec) then VF= OVF( NSURF, NSTRUC, NPLAST, NDIRA(NDIR) ) AF= OAF( NSURF, NSTRUC, NPLAST, NDIRA(NDIR) ) endif WTOT= 0. c ... calculate the A and V response values for each mode c The equations require W in kips and result in c A0 in Gs and V0 in ft/sec. DO 40 I= 1, MODES PB(I)= PARTIC( I, NDIR ) W(I)= PB( I ) * PB( I ) * .3864 c ... provide for interpolation based on a user input spectrum c calculate AM from user spectrum if (userspec) then freq = omeg(i) / twopi call interp(maxpoints, + ndira(ndir),freq,am(i),aspec,numpoints, + logfreq,logdisp) c ... calculate AM form equations and coefficients else c spectral velocity (all configurations) V0= VF * VA(NSURF,NSTRUC,NPLAST) * + ( VB(NSURF,NSTRUC,NPLAST) + W(I) ) / * ( VC(NSURF,NSTRUC,NPLAST) + W(I) ) c spectral acceleration c surface ship, hull or shell mounted equipment IF( ( NSURF .EQ. 1 ) .AND. ( NSTRUC .EQ. 2 ) .OR. + ( NSURF .EQ. 1 ) .AND. ( NSTRUC .EQ. 3 ) ) THEN A0= AF * AA(NSURF,NSTRUC,NPLAST) * + ( AB(NSURF,NSTRUC,NPLAST) + W(I) ) * + ( AC(NSURF,NSTRUC,NPLAST) + W(I) ) / + ( ( AD(NSURF,NSTRUC,NPLAST) + W(I) ) ** 2. ) c all other configurations ELSE A0= AF * AA(NSURF,NSTRUC,NPLAST) * + ( AB(NSURF,NSTRUC,NPLAST) + W(I) ) / * ( AC(NSURF,NSTRUC,NPLAST) + W(I) ) END IF c ... determine the appropriate factor (lower of A0 and V0omega) c am(i) in in/sec/sec AV = V0 * omeg(i) / 386.4 IF( AV .lt. A0) then AM(I)= AV * 386.4 ELSE AM(I)= A0 * 386.4 END IF endif c ... if spectral acceleration < 1G, use 1 G IF( AM(I) .LT. 386.4 ) AM(I)= 386.4 c ... calculate the UHVR matrices for input back to Nastran c (really the "q" values) UHV(I,3,NDIR)= ABS( PB( I ) ) * AM( I ) UHV(I,2,NDIR)= UHV( I, 3,NDIR ) / OMEG( I ) UHV(I,1,NDIR)= UHV( I, 2,NDIR ) / OMEG( I ) C calculate the modal mass percent and cutoff at a given C percentage specified by PREF if (standard) then WPERC(I) = W(I) * 100. / MTOT(NDIR,1) / .3864 WTOT= WTOT + W( I ) WTOTP(I) = WTOT * 100. / MTOT(NDIR,1) / .3864 KREF=I IF (WTOTP(I) .GE. PREF) THEN DO K=I+1,MODES do itype = 1,3 UHV(K,itype,NDIR)= 0. enddo ENDDO GOTO 41 ENDIF c ... if doing a single mode analysis, make all the UHVs zero c except the mode flagged as the target else KREF=target wtotp(kref) = W(I) * 100. / MTOT(NDIR,1) / .3864 DO k = 1,modes do itype = 1,3 if (k .ne. target) then UHV(K,itype,NDIR)= 0. endif enddo ENDDO endif 40 CONTINUE c ... write the verification file 41 CALL HEADER( iover, NSURF, NSTRUC, NPLAST, + NDIR, NDIRA(NDIR), NAMEP,NAMEP1,userspec) MFRACT(NDIR,1)= 100.* MFRACT(NDIR,1) W1=MTOT(NDIR,1)*GRAV WRITE( iover, 1) MFRACT(NDIR,1),W1 WRITE( iover, 171) WTOTP(KREF) 1 FORMAT(/,T10,'MASS AVAILABLE THIS DIRECTION ', * F8.2,' PERCENT OF',F10.2,' LBS.') 171 FORMAT(T10,'MASS USED THIS DIRECTION ',F8.2,' PERCENT') WRITE( iover, 170 ) 170 FORMAT(/,/,10X,'MODAL EFFECTIVE MASS TABLE',//, * T23, 'MODAL WEIGHT', + T42, 'CUMULATIVE WEIGHT',/, * T4, 'MODE', + T10, 'FREQ(HZ)', + T22, 'POUNDS %', + T42, 'POUNDS %', + T62, 'PARTIC.', + T72, 'ACCEL (G)',/) WTOT = 0. DO 50 I= 1, KREF F= OMEG( I ) / TWOPI WT= W(I)*1000. WTOT= WTOT + WT A4= AM(I)/386.4 WRITE( iover, 180 ) I, F, WT, WPERC(I), WTOT, WTOTP(I), * PARTIC(I,NDIR), A4 180 FORMAT(T4,I3, + T8, F10.3, + T19, F10.2, + T31, F6.2, + T38, F10.2, + T50, F6.2, + T60, 1PE9.2, + T70, 0PF9.2) 50 CONTINUE c ... write the binary output file for input back to Nastran NR= maxmodes NC= 3 NROW= MODES NCOL= 3 IO=10 30 CONTINUE ndir = 1 do i = 1,nrow do k = 1,3 uhvx(i,k) = uhv(i,k,ndir) enddo c write(6,*) (uhvx(i,j),j=1,3) enddo ndir = 2 do i = 1,nrow do k = 1,3 uhvy(i,k) = uhv(i,k,ndir) enddo c write(6,*) (uhvy(i,j),j=1,3) enddo ndir = 3 do i = 1,nrow do k = 1,3 uhvz(i,k) = uhv(i,k,ndir) enddo c write(6,*) (uhvz(i,j),j=1,3) enddo CALL WRTNAS(OUTNAME(1),UHVX,NR,NC,NROW,NCOL,'BINARY',ioout) CALL WRTNAS(OUTNAME(2),UHVY,NR,NC,NROW,NCOL,'BINARY',ioout) CALL WRTNAS(OUTNAME(3),UHVZ,NR,NC,NROW,NCOL,'BINARY',ioout) CLOSE( UNIT= 1 ) CLOSE( UNIT= 2 ) CLOSE( UNIT= 9 ) CLOSE( UNIT= 10 ) STOP END C................................................................HEADER. C... THIS ROUTINE WRITES A PAGE HEADER SUBROUTINE HEADER( iover,NSURF, NSTRUC, NPLAST, + NDIR, NDIRA, NAMEP, NAMEP1, userspec) CHARACTER*1 ANDIR(3) CHARACTER*20 NAMEP CHARACTER*24 NAMEP1 DATA ANDIR/'X','Y','Z'/ LOGICAL userspec c ... write a form feed character on the 2nd and 3rd headers if (ndir .gt. 1) write(iover,'(a1)') CHAR(12) C ... write filenames to output file for reference if (userspec) then WRITE(iover,114) NAMEP 114 FORMAT(' SPECTRUM FROM FILE: ',A20) else WRITE(iover,112) NAMEP 112 FORMAT(' COEFFECIENTS FROM FILE: ',A20) endif WRITE(iover,113) NAMEP1 113 FORMAT(' INPUT FROM FILE: ',A24,/) if (.not. userspec) then IF( NSURF .EQ. 1 ) WRITE( iover, 100 ) IF( NSURF .EQ. 2 ) WRITE( iover, 110 ) IF( NSTRUC .EQ. 1 ) WRITE( iover, 120 ) IF( NSTRUC .EQ. 2 ) WRITE( iover, 130 ) IF( NSTRUC .EQ. 3 ) WRITE( iover, 135 ) IF( NPLAST .EQ. 1 ) WRITE( iover, 170 ) IF( NPLAST .EQ. 2 ) WRITE( iover, 175 ) IF( NDIRA .EQ. 1 ) WRITE( iover, 140 ) ANDIR(NDIR) IF( NDIRA .EQ. 2 ) WRITE( iover, 150 ) ANDIR(NDIR) IF( NDIRA .EQ. 3 ) WRITE( iover, 160 ) ANDIR(NDIR) endif RETURN 100 FORMAT(/,10X,'..... SURFACE SHIP .....' ) 110 FORMAT(/,10X,'..... SUBMERGED SHIP .....' ) 120 FORMAT(10x,'..... DECK MOUNTED STRUCTURE .....') 130 FORMAT(10x,'..... HULL MOUNTED STRUCTURE .....') 135 FORMAT(10x,'..... SHELL MOUNTED STRUCTURE .....') 170 FORMAT(10x,'..... ELASTIC COEFFICIENTS .....') 175 FORMAT(10x,'..... ELASTIC-PLASTIC COEFFICIENTS .....') 140 FORMAT(/,10X,'..... FORE-&-AFT (',A1,') DIRECTED SHOCK .....' ) 150 FORMAT(/,10X,'..... ATHWARTSHIP (',A1,') DIRECTED SHOCK .....' ) 160 FORMAT(/,10X,'..... VERTICALLY (',A1,') DIRECTED SHOCK .....' ) END C..................................................................MENU. C... THIS ROUTINE OBTAINS THE INPUT AND OUTPUT FILE NAMES. SUBROUTINE MENU1(ddambatch,ioinp,ioout,iocoef,iospec,iover, + usercoef,userspec,NAMEP,NAMEP1, + filein,fileout,filever,filecoef,filespec) CHARACTER*20 NAME,NAMEP CHARACTER*24 NAME1,NAME2,NAME3,NAMEP1 character*80 message1, message2 character*40 filedef, fileroot, filename character*40 filein, fileout,filever CHARACTER*40 filecoef, filespec character*1 flag,answer integer iounit logical binary,batch,ddambatch logical usercoef, userspec logical true, false true = .TRUE. false = .FALSE. c ... my openfile utility added to save the mess opening files c c call openfile(iounit,filedef,message1,message2, c + flag,binary,batch) c ... check for user input spectrum IF (ddambatch) then if (userspec) then answer = 'S' elseif (usercoef) then answer = 'C' else answer = ' ' endif batch = .true. ELSE batch = .false. write(6,*) write(6,*) ' Do you have a shock spectrum or are you using' write(6,*) ' coefficients ?' write(6,*) ' ... = use default coefficients' write(6,*) ' ... c = use other coefficient file' write(6,*) ' ... s = user input shock spectrum' read(5,'(a)') answer call alf(answer) ENDIF c ... set flag if ok, query and open another file if not ok 10 if (answer .eq. ' ') then usercoef = false userspec = false NAMEP = '(DEFAULT)' ELSEIF (answer .eq. 'C') then message1 = 'What is the name of the coefficient file ?' message2 = 'That file does not exist !' if (ddambatch) then filedef = filecoef else filedef = 'coef.dat' endif binary = .false. flag = 'o' call openfile(iocoef,filedef,message1,message2, + flag,binary,batch) usercoef = true userspec = false NAMEP = filedef ELSEIF (answer .eq. 'S') then message1 = 'What is the name of the spectrum file ?' message2 = 'That file does not exist !' if (ddambatch) then filedef = filespec else filedef = 'spec.dat' endif binary = .false. flag = 'o' call openfile(iospec,filedef,message1,message2, + flag,binary,batch) usercoef = false userspec = true NAMEP = filedef ELSE write(6,*) ' Lets try this again ...' write(6,*) write(6,*) ' Do you have a shock spectrum or are you using' write(6,*) ' coefficients ?' write(6,*) ' ... = use default coefficients' write(6,*) ' ... c = use other coefficient file' write(6,*) ' ... s = user input shock spectrum' read(5,'(a)') answer call alf(answer) goto 10 ENDIF c ... open the .f11 file from Nastran IF (ddambatch) then batch = .true. filedef = filein ELSE batch = .false. filedef = 'ddam.f11' ENDIF message1 = ' ENTER THE DESIRED NASTRAN INPUT FILE NAME: ' message2 = 'That file does not exist !' binary = .true. flag = 'o' call openfile(ioinp,filedef,message1,message2, + flag,binary,batch) namep1 = filedef c ... build a default filename for the verification file call getroot(filedef,fileroot) call addext(fileroot,'ver',filedef) c ... open the verification file IF (ddambatch) then batch = .true. filedef = filever ELSE batch = .false. ENDIF message1 = ' ENTER THE DESIRED VERIFICATION OUTPUT FILE NAME: ' message2 = ' cannot open that file ' binary = .false. flag = 'n' call openfile(iover,filedef,message1,message2, + flag,binary,batch) name2 = filedef c ... build a filename for the output file call addext(fileroot,'f13',filedef) c ... open the output file IF (ddambatch) then batch = .true. filedef = fileout ELSE batch = .false. ENDIF message1 = ' ENTER THE DESIRED NASTRAN OUTPUT FILE NAME: ' message2 = ' cannot open that file ' binary = .true. flag = 'n' call openfile(ioout,filedef,message1,message2, + flag,binary,batch) name3 = filedef RETURN END C...........................................................MENU2. C... THIS MENU ALLOWS THE USER TO INPUT THE PARAMETERS FOR THE C TYPE OF ANALYSIS TO BE PERFORMED SUBROUTINE MENU2(NSURF,NSTRUC,NPLAST, + surface,submarine,deck,hull,shell,elastic,plastic) INTEGER NSURF, NSTRUC,NPLAST LOGICAL surface, submarine LOGICAL deck, hull, shell LOGICAL elastic, plastic write(6,*) write(6,*) ' What type of ship do we have ?' if (surface) then write(*,'(A,A)')' ... Enter 1 for SURFACE ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 1 for SURFACE ', + '(default coefficients)' endif if (submarine) then write(*,'(A,A)')' ... Enter 2 for SUBMERGED ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 2 for SUBMERGED ', + '(default coefficients)' endif READ(*,*) NSURF write(6,*) write(6,*) ' Where is the equipment mounted ?' if (deck) then write(*,'(A,A)')' ... Enter 1 for DECK ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 1 for DECK ', + '(default coefficients)' endif if (hull) then write(*,'(A,A)')' ... Enter 2 for HULL ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 2 for HULL ', + '(default coefficients)' endif if (shell) then write(*,'(A,A)')' ... Enter 3 for SHELL ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 3 for SHELL ', + '(default coefficients)' endif READ(*,*) NSTRUC write(6,*) write(6,*) ' What type of factors do you want ?' if (elastic) then write(*,'(A,A)')' ... Enter 1 for ELASTIC ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 1 for ELASTIC ', + '(default coefficients)' endif if (plastic) then write(*,'(A,A)')' ... Enter 2 for EL-PL ', + '(user coefficients)' else write(*,'(A,A)')' ... Enter 2 for EL-PL ', + '(default coefficients)' endif READ(*,*) NPLAST RETURN END C .......................................................... C this routine acccepts arrangements for bizzare orthogonalcoordinates C by asking the user to supply the shipboard orientation of the local C axis system with respect to ship coordinates. ALF converts small letters C into capitals so that FORTRAN doesn't get confused. ( ALF ? ) SUBROUTINE MENU3(ddambatch,axes,NDIRA) LOGICAL ddambatch INTEGER NDIRA(3) CHARACTER*1 NF,NV, axes(2) if (ddambatch) then nf = axes(1) nv = axes(2) else WRITE (*,'(A)')' ENTER F/A DIRECTION (X,Y,OR Z):' READ(5,1) NF CALL ALF(NF) WRITE (*,'(A)')' ENTER VERTICAL DIRECTION (X,Y,OR Z):' READ(5,1) NV CALL ALF(NV) 1 FORMAT(A1) endif IF (NF .EQ. 'X' .AND. NV .EQ. 'Z') THEN NDIRA(1)=1 NDIRA(2)=2 NDIRA(3)=3 ELSEIF (NF .EQ. 'X' .AND. NV .EQ. 'Y') THEN NDIRA(1)=1 NDIRA(2)=3 NDIRA(3)=2 ELSEIF (NF .EQ. 'Y' .AND. NV .EQ. 'Z') THEN NDIRA(1)=2 NDIRA(2)=1 NDIRA(3)=3 ELSEIF (NF .EQ. 'Y' .AND. NV .EQ. 'X') THEN NDIRA(1)=3 NDIRA(2)=1 NDIRA(3)=2 ELSEIF (NF .EQ. 'Z' .AND. NV .EQ. 'X') THEN NDIRA(1)=3 NDIRA(2)=2 NDIRA(3)=1 ELSEIF (NF .EQ. 'Z' .AND. NV .EQ. 'Y') THEN NDIRA(1)=2 NDIRA(2)=3 NDIRA(3)=1 ENDIF RETURN END C..........................................................LDCOEF. C... THIS ROUTINE READS THE COEFFICIENTS FOR A FILE c c this reads COEF and CUTOFF cards to load coefficients SUBROUTINE LDCOEF(iocoef,maxlines, + ovf,oaf, + va,vb,vc,aa,ab,ac,ad, + pref, + surface, submarine, deck, hull, shell, elastic, plastic) c ... The new format for coeficients assumes that you have 13 coeficients c for each configuration and reads them in on a COEF card that c works like a NASTRAN bulk data deck card. c COEF format c COEF nsurf nstruc nplast c OVF(1) OVF(2) OVF(3) OAF(1) OAF(2) OAF(3) c VA VB VC AA AB AC AD c To accept the default for any value, enter * in the field or leave it blank c OxF(i) the i is for f/a, athw, vert (not necessarily x,y,z) c valid nsurf are SUB, SURF c valid nstruc are DECK, HULL, SHELL c valid nplast are ELASTIC, ELPL c CUTOFF format c CUTOFF pref c cards starting with $ are considered comments REAL OVF(2,3,2,3),OAF(2,3,2,3) REAL AA(2,3,2),AB(2,3,2),AC(2,3,2),AD(2,3,2) REAL VA(2,3,2),VB(2,3,2),VC(2,3,2) REAL pref LOGICAL elastic, plastic LOGICAL hull, deck, shell LOGICAL surface, submarine LOGICAL true, false, error CHARACTER*80 line CHARACTER*8 surf, struc, plast, adat(7) true = .TRUE. false = .FALSE. error = false do 101 iline = 1,maxlines error = false read(iocoef,'(a)',end=999) line if (line(1:1) .eq. '$') goto 101 if (line(1:1) .eq. '#') goto 101 if (line(1:8) .eq. 'COEF ') then read(line,11) surf,struc,plast 11 format(8x,3a8) if (index(surf,'SURF') .ne. 0) then nsurf = 1 surface = true elseif (index(surf,'SUB') .ne. 0) then nsurf = 2 submarine = true else write(6,*) ' Invalid field 2 on card ',iline error = true endif if (index(struc,'DECK') .ne. 0) then nstruc = 1 deck = true elseif (index(struc,'HULL') .ne. 0) then nstruc = 2 hull = true elseif (index(struc,'SHELL') .ne. 0) then nstruc = 3 shell = true else write(6,*) ' Invalid field 3 on card ',iline error = true endif if (index(plast,'ELASTIC') .ne. 0) then nplast = 1 elastic = true elseif (index(plast,'ELPL') .ne. 0) then nplast = 2 plastic = true else write(6,*) ' Invalide field 4 on card ',iline error = true endif if (error) goto 101 c ... read the OVF and OAF factors (looking for * fields read(iocoef,12) (adat(iterm),iterm=1,6) 12 format(8x,6a8) do iterm = 1,3 if ( (index(adat(iterm),'*') .eq. 0) .and. + (length(adat(iterm)) .ne. 0) ) then read(adat(iterm),*) ovf(nsurf,nstruc,nplast,iterm) endif enddo do iterm = 4,6 it = iterm-3 if (index(adat(iterm),'*') .eq. 0 .and. + length(adat(iterm)) .ne. 0) then read(adat(iterm),*) oaf(nsurf,nstruc,nplast,it) endif enddo c ... read the Ax and Vx factors read(iocoef,13) (adat(iterm),iterm=1,7) 13 format(8x,7a8) if (index(adat(1),'*') .eq. 0 .and. + length(adat(1)) .ne. 0) + read(adat(1),*) va(nsurf,nstruc,nplast) if (index(adat(2),'*') .eq. 0 .and. + length(adat(2)) .ne. 0) + read(adat(2),*) vb(nsurf,nstruc,nplast) if (index(adat(3),'*') .eq. 0 .and. + length(adat(3)) .ne. 0) + read(adat(3),*) vc(nsurf,nstruc,nplast) if (index(adat(4),'*') .eq. 0 .and. + length(adat(4)) .ne. 0) + read(adat(4),*) aa(nsurf,nstruc,nplast) if (index(adat(5),'*') .eq. 0 .and. + length(adat(5)) .ne. 0) + read(adat(5),*) ab(nsurf,nstruc,nplast) if (index(adat(6),'*') .eq. 0 .and. + length(adat(6)) .ne. 0) + read(adat(6),*) ac(nsurf,nstruc,nplast) if (index(adat(7),'*') .eq. 0 .and. + length(adat(7)) .ne. 0) + read(adat(7),*) ad(nsurf,nstruc,nplast) endif if (line(1:8) .eq. 'CUTOFF ') then read(line,14) pref 14 format(8x,f8.5) endif 101 continue 999 continue RETURN END c ***** ------------------------------------------------------ ***** SUBROUTINE ALF(RALF) C C............THIS SUBROUTINE CONVERTS AN ALPHA CHARACTER C TO UPPERCASE IF IT IS GREATER THAN C 96 (DECIMAL). ("a" IS 97 (DECIMAL)) C CHARACTER*1 RALF I=ICHAR(RALF) IF(I.LE.96.OR.I.GE.123) RETURN C C............SMALL LETTER C RALF=CHAR(I-32) RETURN END c ***** ------------------------------------------------------------ ***** INTEGER FUNCTION LENGTH(STRING) CHARACTER *(*) STRING I=LEN(STRING) if (i .le. 0) then length=0 return endif DO WHILE (I.GE.1 .AND. STRING(I:I) .EQ. ' ') I=I-1 END DO LENGTH=I RETURN END c ***** ------------------------------------------------------------ ***** subroutine openfile(iounit,filedef,message1,message2, + flag,binary,batch) c call openfile(iosum,filesum,message1,message2, c + flag,binary,batch) c ----- subroutine to open a file given various values passed to it: c iounit = unit number to open c filedef = filename to use as the default filename c message1 = text to display asking what file to open c message2 = text to display if the file cannot be opened c flag = status flag (o = old, n = new, u = unknown) c binary = logical for format (T = unformatted, F = formatted) c batch - logical for batch execution: if T then c no message 1 displayed c existing files overwritten character*(*) message1,message2 character*(*) filedef character*80 fileopen character*1 flag,answer integer iounit logical binary,batch if (flag .eq. 'o') then if (batch) then fileopen = filedef else write(6,'(a)') message1 write(6,'(a,a)') ' Default: = ',filedef read(5,'(a)') fileopen if (fileopen .eq. ' ') fileopen = filedef endif 1 if (binary) then open(iounit,file=fileopen,status='old',iostat=ierr, + form='unformatted') else open(iounit,file=fileopen,status='old',iostat=ierr) endif if (ierr .ne. 0) then write(6,'(a)') message2 lname = length(fileopen) write(6,'(a,a,a)') ' File ',fileopen(1:lname), + ' could not be opened.' if (batch) then write(6,*) ' FATAL ERROR - PROGRAM STOPPING' stop else write(6,*) ' Lets try again ...' write(6,*) message1 read(5,'(a)') fileopen goto 1 endif endif elseif (flag .eq. 'n') then if (batch) then fileopen = filedef else write(6,'(a)') message1 write(6,'(a,a)') ' Default: = ',filedef read(5,'(a)') fileopen if (fileopen .eq. ' ') fileopen = filedef endif 2 if (binary) then open(iounit,file=fileopen,status='new',iostat=ierr, + form ='unformatted') else open(iounit,file=fileopen,status='new',iostat=ierr) endif if (ierr .ne. 0) then if (batch) then open(iounit,file=fileopen,status='old') close(iounit,status='delete') if (binary) then open(iounit,file=fileopen,status='new', + form='unformatted') else open(iounit,file=fileopen,status='new') endif else write(6,*) 'That file already exists. Ok to overwrite ?' read(5,'(a1)') answer if (answer .eq. 'y') then open(iounit,file=fileopen,status='old') close(iounit,status='delete') if (binary) then open(iounit,file=fileopen,status='new', + form='unformatted') else open(iounit,file=fileopen,status='new') endif else write (6,*) ' Ok then, lets try this again ...' write (6,*) message1 read(5,'(a)') fileopen goto 2 endif endif endif elseif(flag .eq. 'u') then if (.not. batch) then write(6,'(a)') message1 write(6,'(a,a)') ' Default: = ',filedef read(5,'(a)') fileopen if (fileopen .eq. ' ') fileopen = filedef endif 3 if (binary) then open(iounit,file=fileopen,status='unknown',iostat=ierr, + form ='unformatted') else open(iounit,file=fileopen,status='unknown',iostat=ierr) endif if (ierr .ne. 0) then write(6,*) ' There is something seriously wrong with your' write(6,*) ' system. Do you have permission to open files' write(6,*) ' in this directory ?' if (batch) then write(6,*) ' FATAL ERROR - PROGRAM STOPPING ' stop else write(6,*) ' Try a different filename:' write(6,'(a)') message1 read(5,'(a)') fileopen goto 3 endif endif endif filedef = fileopen nchar = length(filedef) write(6,11) filedef(1:nchar) write(6,12) iounit 11 format( ' ... File name ',a,' opened for i/o ...') 12 format( ' (unit number ',i2,' )') return end c ***** ------------------------------------------------------------- ***** subroutine set_default_coef( + ovf,oaf, + va,vb,vc,aa,ab,ac,ad, + pref) REAL OVF(2,3,2,3),OAF(2,3,2,3) REAL AA(2,3,2),AB(2,3,2),AC(2,3,2),AD(2,3,2) REAL VA(2,3,2),VB(2,3,2),VC(2,3,2) REAL pref c ... equations are assumed to be of the form: c c V = OVF (VA)(VB + W) / (VC + W) c A = OAF (AA)(AB + W) / (AC + W) c A = OAF (AA)(AB + W)(AC + W) / (AD + W)**2 c the OAF and OVF factors have dimensions as follows: c OxF(nsurf, nstruc, nplast, ndir) c nsurf = 1 (surface ship), 2 (submarine) c nstruc = 1 (deck mount), 2 (hull mount), 3 (shell mount) c nplast = 1 (elastic), 2 (elastic-plastic) c ndir = 1 (f/a), 2 (athw shock), 3 (vert shock) c The provided values are those used in the sample problems c ... ELASTIC (nplast = 1) c --- surface ship (nsurf = 1) c deck mount (nstruc = 1) OVF(1,1,1,1) = 1.0 OVF(1,1,1,2) = 1.0 OVF(1,1,1,3) = 1.0 OAF(1,1,1,1) = 1.0 OAF(1,1,1,2) = 1.0 OAF(1,1,1,3) = 1.0 c hull mount (nstruc = 2) OVF(1,2,1,1) = 1.0 OVF(1,2,1,2) = 1.0 OVF(1,2,1,3) = 1.0 OAF(1,2,1,1) = 1.0 OAF(1,2,1,2) = 1.0 OAF(1,2,1,3) = 1.0 c shell mount (nstruc = 3) OVF(1,3,1,1) = 1.0 OVF(1,3,1,2) = 1.0 OVF(1,3,1,3) = 1.0 OAF(1,3,1,1) = 1.0 OAF(1,3,1,2) = 1.0 OAF(1,3,1,3) = 1.0 c --- submarine (nsurf = 2) c deck mount (nstruc = 1) OVF(2,1,1,1) = 1.0 OVF(2,1,1,2) = 1.0 OVF(2,1,1,3) = 1.0 OAF(2,1,1,1) = 1.0 OAF(2,1,1,2) = 1.0 OAF(2,1,1,3) = 1.0 c hull mount (nstruc = 2) OVF(2,2,1,1) = 1.0 OVF(2,2,1,2) = 1.0 OVF(2,2,1,3) = 1.0 OAF(2,2,1,1) = 1.0 OAF(2,2,1,2) = 1.0 OAF(2,2,1,3) = 1.0 c shell mount (nstruc = 3) OVF(2,3,1,1) = 1.0 OVF(2,3,1,2) = 1.0 OVF(2,3,1,3) = 1.0 OAF(2,3,1,1) = 1.0 OAF(2,3,1,2) = 1.0 OAF(2,3,1,3) = 1.0 c ... ELASTIC-PLASTIC (nplast = 2) c --- surface ship (nsurf = 1) c deck mount (nstruc = 1) OVF(1,1,2,1) = 1.0 OVF(1,1,2,2) = 1.0 OVF(1,1,2,3) = 1.0 OAF(1,1,2,1) = 1.0 OAF(1,1,2,2) = 1.0 OAF(1,1,2,3) = 1.0 c hull mount (nstruc = 2) OVF(1,2,2,1) = 1.0 OVF(1,2,2,2) = 1.0 OVF(1,2,2,3) = 1.0 OAF(1,2,2,1) = 1.0 OAF(1,2,2,2) = 1.0 OAF(1,2,2,3) = 1.0 c shell mount (nstruc = 3) OVF(1,3,2,1) = 1.0 OVF(1,3,2,2) = 1.0 OVF(1,3,2,3) = 1.0 OAF(1,3,2,1) = 1.0 OAF(1,3,2,2) = 1.0 OAF(1,3,2,3) = 1.0 c --- submarine (nsurf = 2) c deck mount (nstruc = 1) OVF(2,1,2,1) = 1.0 OVF(2,1,2,2) = 1.0 OVF(2,1,2,3) = 1.0 OAF(2,1,2,1) = 1.0 OAF(2,1,2,2) = 1.0 OAF(2,1,2,3) = 1.0 c hull mount (nstruc = 2) OVF(2,2,2,1) = 1.0 OVF(2,2,2,2) = 1.0 OVF(2,2,2,3) = 1.0 OAF(2,2,2,1) = 1.0 OAF(2,2,2,2) = 1.0 OAF(2,2,2,3) = 1.0 c shell mount (nstruc = 3) OVF(2,3,2,1) = 1.0 OVF(2,3,2,2) = 1.0 OVF(2,3,2,3) = 1.0 OAF(2,3,2,1) = 1.0 OAF(2,3,2,2) = 1.0 OAF(2,3,2,3) = 1.0 c ... the Vx and Ax have dimensions as follows: c Vx (nsurf, nstruc) c nsurf = 1 (surface ship), 2 (submarine) c nstruc = 1 (deck mount), 2 (hull mount), 3 (shell mount) c nplast = 1 (elastic), 2 (elastic-plastic) c ... ELASTIC (nplast=1) c --- surface ship (nsurf = 1) c deck mount (nstruc = 1) VA(1,1,1) = 120. VB(1,1,1) = 50. VC(1,1,1) = 10. AA(1,1,1) = 50. AB(1,1,1) = 40. AC(1,1,1) = 10. AD(1,1,1) = 0. c hull mount (nstruc = 2) VA(1,2,1) = 120. VB(1,2,1) = 50. VC(1,2,1) = 10. AA(1,2,1) = 50. AB(1,2,1) = 40. AC(1,2,1) = 10. AD(1,2,1) = 0. c shell mount (nstruc = 3) VA(1,3,1) = 120. VB(1,3,1) = 50. VC(1,3,1) = 10. AA(1,3,1) = 50. AB(1,3,1) = 40. AC(1,3,1) = 10. AD(1,3,1) = 0. c --- submarine (nsurf = 2) c deck mount (nstruc = 1) VA(2,1,1) = 120. VB(2,1,1) = 50. VC(2,1,1) = 10. AA(2,1,1) = 50. AB(2,1,1) = 40. AC(2,1,1) = 10. AD(2,1,1) = 0. c hull mount (nstruc = 2) VA(2,2,1) = 120. VB(2,2,1) = 50. VC(2,2,1) = 10. AA(2,2,1) = 50. AB(2,2,1) = 40. AC(2,2,1) = 10. AD(2,2,1) = 0. c shell mount (nstruc = 3) VA(2,3,1) = 120. VB(2,3,1) = 50. VC(2,3,1) = 10. AA(2,3,1) = 50. AB(2,3,1) = 40. AC(2,3,1) = 10. AD(2,3,1) = 0. c ... ELASTIC-PLASTIC (nplast=2) c --- surface ship (nsurf = 1) c deck mount (nstruc = 1) VA(1,1,2) = 120. VB(1,1,2) = 50. VC(1,1,2) = 10. AA(1,1,2) = 50. AB(1,1,2) = 40. AC(1,1,2) = 10. AD(1,1,2) = 0. c hull mount (nstruc = 2) VA(1,2,2) = 120. VB(1,2,2) = 50. VC(1,2,2) = 10. AA(1,2,2) = 50. AB(1,2,2) = 40. AC(1,2,2) = 10. AD(1,2,2) = 0. c shell mount (nstruc = 3) VA(1,3,2) = 120. VB(1,3,2) = 50. VC(1,3,2) = 10. AA(1,3,2) = 50. AB(1,3,2) = 40. AC(1,3,2) = 10. AD(1,3,2) = 0. c --- submarine (nsurf = 2) c deck mount (nstruc = 1) VA(2,1,2) = 120. VB(2,1,2) = 50. VC(2,1,2) = 10. AA(2,1,2) = 50. AB(2,1,2) = 40. AC(2,1,2) = 10. AD(2,1,2) = 0. c hull mount (nstruc = 2) VA(2,2,2) = 120. VB(2,2,2) = 50. VC(2,2,2) = 10. AA(2,2,2) = 50. AB(2,2,2) = 40. AC(2,2,2) = 10. AD(2,2,2) = 0. c shell mount (nstruc = 3) VA(2,3,2) = 120. VB(2,3,2) = 50. VC(2,3,2) = 10. AA(2,3,2) = 50. AB(2,3,2) = 40. AC(2,3,2) = 10. AD(2,3,2) = 0. c ... set the default weight cutoff pref = 80. return end