├── additional_files ├── batch-run-p1.sh ├── compliances ├── feistrs ├── feistrs_do_hcp.pl ├── frs-to-csv_gp.sh └── slip_systems │ ├── Magnesium │ ├── Titanium │ └── Zirconium ├── docs ├── CPFEM_guidelines_from_Dim │ ├── CPFE model guidelines.docx │ ├── ZrRD2_explained.fmt │ └── prein_labelled pete 18 systems.txt ├── CPFEM_introduction.doc └── Hardening.pdf ├── sample_input_files ├── aluminium2.fmt ├── dirname ├── fafcdf.dat ├── fe_input2.txt ├── fs3pre_inputs.txt └── random-E.ori └── src ├── csvmkr ├── csvmkr.f90 ├── data_in.f90 ├── data_out.f90 ├── fas-con-mod.f90 ├── fspl_orir.f90 └── makefile ├── fasolt ├── Bconds.f90 ├── Cpstrs.f90 ├── Elvals.f90 ├── Faslt_io.f90 ├── Faslt_io_nowin.f90 ├── Faslt_io_nowin_gam.f90 ├── Fasolt3.f90 ├── Shapef.f90 ├── Sig_eps.f90 ├── Stif_sol.f90 ├── crys-cons.f90 ├── crys_math.f90 ├── ela-plas.f90 ├── fas-com-mod.f90 └── makefile └── prepro ├── crysdat.f90 ├── fas_com_mod.f90 ├── fs2-xtal.f90 ├── fs3p-bkc.f90 ├── fs3p-gps.f90 ├── fs3p-io_nowin.f90 ├── fs3p-matl.f90 ├── fs3p-rcm.f90 ├── fs3p-swp.f90 ├── fs3pre.f90 └── makefile /additional_files/batch-run-p1.sh: -------------------------------------------------------------------------------- 1 | rm *.csv *.dat *.frs; 2 | 3 | ls -latr /home/mclssgt2/bin > verinfo 4 | /home/mclssgt2/bin/fs3pre < fs3pre_inputs.txt ; 5 | /home/mclssgt2/bin/fasolt3 < fe_input2.txt ; 6 | # perl /home/tsivoulas/bin/perl/gstress.pl ","tmp") ||die "can't open tmp file $!"; 30 | $file_in=$_; 31 | $file_out="d\_$nice_indices\_$_"; 32 | print TMP_FILE "$crystal\n$ca\n$indices\n$angle_tol\n$file_in\n$file_out\n"; 33 | close(TMP_FILE) || die "can't close tmp file"; 34 | #print "Doing $_:"; 35 | system("/home/mclssgt2/bin/feistrs < tmp > log"); 36 | #print " done\n"; 37 | 38 | } 39 | } 40 | } 41 | 42 | -------------------------------------------------------------------------------- /additional_files/frs-to-csv_gp.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | for fname in *.frs 4 | do 5 | 6 | #echo $fname 7 | #extension="${fname##*.}" 8 | filename="${fname%.*}" 9 | 10 | #echo $extension 11 | #echo $filename 12 | 13 | csvmkr < /dev/null 14 | $filename 15 | 2 16 | $filename 17 | STDIN 18 | 19 | 20 | done 21 | -------------------------------------------------------------------------------- /additional_files/slip_systems/Magnesium: -------------------------------------------------------------------------------- 1 | % Slip and twinning systems in Mg (c/a = 1.624) 2 | % first 3 numbers: direction, second 3 numbers: plane normal 3 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4 | 5 | % Slip systems: 6 | %---------------------------------------------- 7 | % {0 0 0 1} <-1 2 -1 0> basal slip (in direction) 8 | 0.5 0.866 0.0 0.0 0.0 1.0 9 | 0.5 -0.866 0.0 0.0 0.0 1.0 10 | 1.0 0.0 0.0 0.0 0.0 1.0 11 | 12 | % {1 0 -1 0} <-1 2 -1 0> prism slip (in direction) 13 | 0.5 0.866 0.0 0.866 -0.5 0.0 14 | 0.5 -0.866 0.0 0.866 0.5 0.0 15 | 1.0 0.0 0.0 0.0 1.0 0.0 16 | 17 | % {1 0 -1 1} <-1 2 -1 0> pyramidal slip (in direction) 18 | 0.5 -0.866 0.0 0.764 0.441 0.471 19 | 1.0 0.0 0.0 0.0 0.882 0.471 20 | 0.5 0.866 0.0 -0.764 0.441 0.471 21 | 0.5 -0.866 0.0 -0.764 -0.441 0.471 22 | 1.0 0.0 0.0 0.0 -0.882 0.471 23 | 0.5 0.866 0.0 0.764 -0.441 0.471 24 | 25 | % {1 0 -1 1} <-1 -1 2 3> 1st order pyramidal slip (in direction) 26 | -0.262 -0.454 0.852 0.764 0.441 0.471 27 | -0.524 0.0 0.852 0.764 0.441 0.471 28 | 0.262 -0.454 0.852 0.0 0.882 0.471 29 | -0.262 -0.454 0.852 0.0 0.882 0.471 30 | 0.524 0.0 0.852 -0.764 0.441 0.471 31 | 0.262 -0.454 0.852 -0.764 0.441 0.471 32 | 0.262 0.454 0.852 -0.764 -0.441 0.471 33 | 0.524 0.0 0.852 -0.764 -0.441 0.471 34 | -0.262 0.454 0.852 0.0 -0.882 0.471 35 | 0.262 0.454 0.852 0.0 -0.882 0.471 36 | -0.524 0.0 0.852 0.764 -0.441 0.471 37 | -0.262 0.454 0.852 0.764 -0.441 0.471 38 | 39 | % {1 1 -2 2} <-1 -1 2 3> 2nd order pyramidal slip (in direction) 40 | -0.262 -0.454 0.852 0.426 0.737 0.524 41 | 0.262 -0.454 0.852 -0.426 0.737 0.524 42 | 0.524 0.0 0.852 -0.852 0.0 0.524 43 | 0.262 0.454 0.852 -0.426 -0.737 0.524 44 | -0.262 0.454 0.852 0.426 -0.737 0.524 45 | -0.524 0.0 0.852 0.852 0.0 0.524 46 | 47 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 48 | % Twinning systems: 49 | % ------------------------------------------ 50 | % {1 0 -1 2} <-1 0 1 1> tension twin 51 | -0.632 -0.365 0.684 0.592 0.342 0.73 52 | 0.0 -0.73 0.684 0.0 0.684 0.73 53 | 0.632 -0.365 0.684 -0.592 0.342 0.73 54 | 0.632 0.365 0.684 -0.592 -0.342 0.73 55 | 0.0 0.73 0.684 0.0 -0.684 0.73 56 | -0.632 0.365 0.684 0.592 -0.342 0.73 57 | 58 | % {1 1 -2 1} <-1 -1 2 6> tension twin 59 | -0.147 -0.255 0.956 0.478 0.828 0.294 60 | 0.147 -0.255 0.956 -0.478 0.828 0.294 61 | 0.294 0.0 0.956 -0.956 0.0 0.294 62 | 0.147 0.255 0.956 -0.478 -0.828 0.294 63 | -0.147 0.255 0.956 0.478 -0.828 0.294 64 | -0.294 0.0 0.956 0.956 0.0 0.294 65 | 66 | % {1 1 -2 2} <1 1 -2 -3> compression twin 67 | 0.262 0.454 -0.852 0.426 0.737 0.524 68 | -0.262 0.454 -0.852 -0.426 0.737 0.524 69 | -0.524 0.0 -0.852 -0.852 0.0 0.524 70 | -0.262 -0.454 -0.852 -0.426 -0.737 0.524 71 | 0.262 -0.454 -0.852 0.426 -0.737 0.524 72 | 0.524 0.0 -0.852 0.852 0.0 0.524 73 | 74 | % {1 0 -1 1} <1 0 -1 -2> compression twin 75 | 0.408 0.235 -0.882 0.764 0.441 0.471 76 | 0.0 0.471 -0.882 0.0 0.882 0.471 77 | -0.408 0.235 -0.882 -0.764 0.441 0.471 78 | -0.408 -0.235 -0.882 -0.764 -0.441 0.471 79 | 0.0 -0.471 -0.882 0.0 -0.882 0.471 80 | 0.408 -0.235 -0.882 0.764 -0.441 0.471 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /additional_files/slip_systems/Titanium: -------------------------------------------------------------------------------- 1 | % Slip and twinning systems in Ti (c/a = 1.587) 2 | % first 3 numbers: direction, second 3 numbers: plane normal 3 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4 | 5 | % Slip systems: 6 | %---------------------------------------------- 7 | % {0 0 0 1} <-1 2 -1 0> basal slip (in direction) 8 | 0.5 0.866 0.0 0.0 0.0 1.0 9 | 0.5 -0.866 0.0 0.0 0.0 1.0 10 | 1.0 0.0 0.0 0.0 0.0 1.0 11 | 12 | % {1 0 -1 0} <-1 2 -1 0> prism slip (in direction) 13 | 0.5 0.866 0.0 0.866 -0.5 0.0 14 | 0.5 -0.866 0.0 0.866 0.5 0.0 15 | 1.0 0.0 0.0 0.0 1.0 0.0 16 | 17 | % {1 0 -1 1} <-1 2 -1 0> pyramidal slip (in direction) 18 | 0.5 -0.866 0.0 0.76 0.439 0.479 19 | 1.0 0.0 0.0 0.0 0.878 0.479 20 | 0.5 0.866 0.0 -0.76 0.439 0.479 21 | 0.5 -0.866 0.0 -0.76 -0.439 0.479 22 | 1.0 0.0 0.0 0.0 -0.878 0.479 23 | 0.5 0.866 0.0 0.76 -0.439 0.479 24 | 25 | % {1 0 -1 1} <-1 -1 2 3> 1st order pyramidal slip (in direction) 26 | -0.267 -0.462 0.846 0.76 0.439 0.479 27 | -0.533 0.0 0.846 0.76 0.439 0.479 28 | 0.267 -0.462 0.846 0.0 0.878 0.479 29 | -0.267 -0.462 0.846 0.0 0.878 0.479 30 | 0.533 0.0 0.846 -0.76 0.439 0.479 31 | 0.267 -0.462 0.846 -0.76 0.439 0.479 32 | 0.267 0.462 0.846 -0.76 -0.439 0.479 33 | 0.533 0.0 0.846 -0.76 -0.439 0.479 34 | -0.267 0.462 0.846 0.0 -0.878 0.479 35 | 0.267 0.462 0.846 0.0 -0.878 0.479 36 | -0.533 0.0 0.846 0.76 -0.439 0.479 37 | -0.267 0.462 0.846 0.76 -0.439 0.479 38 | 39 | % {1 1 -2 2} <-1 -1 2 3> 2nd order pyramidal slip (in direction) 40 | -0.267 -0.462 0.846 0.423 0.733 0.533 41 | 0.267 -0.462 0.846 -0.423 0.733 0.533 42 | 0.533 0.0 0.846 -0.846 0.0 0.533 43 | 0.267 0.462 0.846 -0.423 -0.733 0.533 44 | -0.267 0.462 0.846 0.423 -0.733 0.533 45 | -0.533 0.0 0.846 0.846 0.0 0.533 46 | 47 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 48 | % Twinning systems: 49 | % ------------------------------------------ 50 | % {1 0 -1 2} <-1 0 1 1> tension twin 51 | -0.639 -0.369 0.676 0.585 0.338 0.737 52 | 0.0 -0.737 0.676 0.0 0.676 0.737 53 | 0.639 -0.369 0.676 -0.585 0.338 0.737 54 | 0.639 0.369 0.676 -0.585 -0.338 0.737 55 | 0.0 0.737 0.676 0.0 -0.676 0.737 56 | -0.639 0.369 0.676 0.585 -0.338 0.737 57 | 58 | % {1 1 -2 1} <-1 -1 2 6> tension twin 59 | -0.15 -0.26 0.954 0.477 0.826 0.301 60 | 0.15 -0.26 0.954 -0.477 0.826 0.301 61 | 0.301 0.0 0.954 -0.954 0.0 0.301 62 | 0.15 0.26 0.954 -0.477 -0.826 0.301 63 | -0.15 0.26 0.954 0.477 -0.826 0.301 64 | -0.301 0.0 0.954 0.954 0.0 0.301 65 | 66 | % {1 1 -2 2} <1 1 -2 -3> compression twin 67 | 0.267 0.462 -0.846 0.423 0.733 0.533 68 | -0.267 0.462 -0.846 -0.423 0.733 0.533 69 | -0.533 0.0 -0.846 -0.846 0.0 0.533 70 | -0.267 -0.462 -0.846 -0.423 -0.733 0.533 71 | 0.267 -0.462 -0.846 0.423 -0.733 0.533 72 | 0.533 0.0 -0.846 0.846 0.0 0.533 73 | 74 | % {1 0 -1 1} <1 0 -1 -2> compression twin 75 | 0.415 0.24 -0.878 0.76 0.439 0.479 76 | 0.0 0.479 -0.878 0.0 0.878 0.479 77 | -0.415 0.24 -0.878 -0.76 0.439 0.479 78 | -0.415 -0.24 -0.878 -0.76 -0.439 0.479 79 | 0.0 -0.479 -0.878 0.0 -0.878 0.479 80 | 0.415 -0.24 -0.878 0.76 -0.439 0.479 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /additional_files/slip_systems/Zirconium: -------------------------------------------------------------------------------- 1 | % Slip and twinning systems in Zr (c/a = 1.593) 2 | % first 3 numbers: direction, second 3 numbers: plane normal 3 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4 | 5 | % Slip systems: 6 | %---------------------------------------------- 7 | % {0 0 0 1} <-1 2 -1 0> basal slip (in direction) 8 | 0.5 0.866 0.0 0.0 0.0 1.0 9 | 0.5 -0.866 0.0 0.0 0.0 1.0 10 | 1.0 0.0 0.0 0.0 0.0 1.0 11 | 12 | % {1 0 -1 0} <-1 2 -1 0> prism slip (in direction) 13 | 0.5 0.866 0.0 0.866 -0.5 0.0 14 | 0.5 -0.866 0.0 0.866 0.5 0.0 15 | 1.0 0.0 0.0 0.0 1.0 0.0 16 | 17 | % {1 0 -1 1} <-1 2 -1 0> pyramidal slip (in direction) 18 | 0.5 -0.866 0.0 0.761 0.439 0.478 19 | 1.0 0.0 0.0 0.0 0.879 0.478 20 | 0.5 0.866 0.0 -0.761 0.439 0.478 21 | 0.5 -0.866 0.0 -0.761 -0.439 0.478 22 | 1.0 0.0 0.0 0.0 -0.879 0.478 23 | 0.5 0.866 0.0 0.761 -0.439 0.478 24 | 25 | % {1 0 -1 1} <-1 -1 2 3> 1st order pyramidal slip (in direction) 26 | -0.266 -0.46 0.847 0.761 0.439 0.478 27 | -0.532 0.0 0.847 0.761 0.439 0.478 28 | 0.266 -0.46 0.847 0.0 0.879 0.478 29 | -0.266 -0.46 0.847 0.0 0.879 0.478 30 | 0.532 0.0 0.847 -0.761 0.439 0.478 31 | 0.266 -0.46 0.847 -0.761 0.439 0.478 32 | 0.266 0.46 0.847 -0.761 -0.439 0.478 33 | 0.532 0.0 0.847 -0.761 -0.439 0.478 34 | -0.266 0.46 0.847 0.0 -0.879 0.478 35 | 0.266 0.46 0.847 0.0 -0.879 0.478 36 | -0.532 0.0 0.847 0.761 -0.439 0.478 37 | -0.266 0.46 0.847 0.761 -0.439 0.478 38 | 39 | % {1 1 -2 2} <-1 -1 2 3> 2nd order pyramidal slip (in direction) 40 | -0.266 -0.46 0.847 0.424 0.734 0.532 41 | 0.266 -0.46 0.847 -0.424 0.734 0.532 42 | 0.532 0.0 0.847 -0.847 0.0 0.532 43 | 0.266 0.46 0.847 -0.424 -0.734 0.532 44 | -0.266 0.46 0.847 0.424 -0.734 0.532 45 | -0.532 0.0 0.847 0.847 0.0 0.532 46 | 47 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 48 | % Twinning systems: 49 | % ------------------------------------------ 50 | % {1 0 -1 2} <-1 0 1 1> tension twin 51 | -0.637 -0.368 0.677 0.586 0.339 0.736 52 | 0.0 -0.736 0.677 0.0 0.677 0.736 53 | 0.637 -0.368 0.677 -0.586 0.339 0.736 54 | 0.637 0.368 0.677 -0.586 -0.339 0.736 55 | 0.0 0.736 0.677 0.0 -0.677 0.736 56 | -0.637 0.368 0.677 0.586 -0.339 0.736 57 | 58 | % {1 1 -2 1} <-1 -1 2 6> tension twin 59 | -0.15 -0.259 0.954 0.477 0.826 0.3 60 | 0.15 -0.259 0.954 -0.477 0.826 0.3 61 | 0.3 0.0 0.954 -0.954 0.0 0.3 62 | 0.15 0.259 0.954 -0.477 -0.826 0.3 63 | -0.15 0.259 0.954 0.477 -0.826 0.3 64 | -0.3 0.0 0.954 0.954 0.0 0.3 65 | 66 | % {1 1 -2 2} <1 1 -2 -3> compression twin 67 | 0.266 0.46 -0.847 0.424 0.734 0.532 68 | -0.266 0.46 -0.847 -0.424 0.734 0.532 69 | -0.532 0.0 -0.847 -0.847 0.0 0.532 70 | -0.266 -0.46 -0.847 -0.424 -0.734 0.532 71 | 0.266 -0.46 -0.847 0.424 -0.734 0.532 72 | 0.532 0.0 -0.847 0.847 0.0 0.532 73 | 74 | % {1 0 -1 1} <1 0 -1 -2> compression twin 75 | 0.414 0.239 -0.879 0.761 0.439 0.478 76 | 0.0 0.478 -0.879 0.0 0.879 0.478 77 | -0.414 0.239 -0.879 -0.761 0.439 0.478 78 | -0.414 -0.239 -0.879 -0.761 -0.439 0.478 79 | 0.0 -0.478 -0.879 0.0 -0.879 0.478 80 | 0.414 -0.239 -0.879 0.761 -0.439 0.478 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /docs/CPFEM_guidelines_from_Dim/CPFE model guidelines.docx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabortimar/CPFEM_code/f01e68becd0d01b774f864e8c83bb9d1081ae282/docs/CPFEM_guidelines_from_Dim/CPFE model guidelines.docx -------------------------------------------------------------------------------- /docs/CPFEM_guidelines_from_Dim/ZrRD2_explained.fmt: -------------------------------------------------------------------------------- 1 | 6.000 ------ number of single crystal hardening parameters that will be input 2 | 18.000 ------ number of slip systems to be included 3 | 1.297E-05 1.297E-05 8.731E-06 -2.748E-06 -2.748E-06 -6.447E-06 3.546E-05 3.546E-05 3.884E-05 ---- elastic compliances: s11 s11 s33 s13 s13 s12 s44 s44 s66 4 | 0.500 0.866 0.000 0.000 0.000 1.000 ---- list of 18 active slip systems. explained in guideline document 5 | 0.500 -0.866 0.000 0.000 0.000 1.000 6 | -1.000 0.000 0.000 0.000 0.000 1.000 7 | 0.500 0.866 0.000 0.866 -0.500 0.000 8 | 0.500 -0.866 0.000 0.866 0.500 0.000 9 | -1.000 0.000 0.000 0.000 -1.000 0.000 10 | 0.266 0.460 0.847 -0.761 -0.439 0.478 11 | 0.266 0.460 0.847 0.000 -0.879 0.478 12 | -0.266 -0.460 0.847 0.761 0.439 0.478 13 | -0.266 -0.460 0.847 0.000 0.879 0.478 14 | 0.266 -0.460 0.847 -0.761 0.439 0.478 15 | 0.266 -0.460 0.847 0.000 0.879 0.478 16 | -0.266 0.460 0.847 0.761 -0.439 0.478 17 | -0.266 0.460 0.847 0.000 -0.879 0.478 18 | -0.532 0.000 0.847 0.761 -0.439 0.478 19 | -0.532 0.000 0.847 0.761 0.439 0.478 20 | 0.532 0.000 0.847 -0.761 0.439 0.478 21 | 0.532 0.000 0.847 -0.761 -0.439 0.478 22 | 0.020 3000.000 0.000 2.100 70.000 0.100 ---- list of 18 hardening parameters for each slip system. defined in guideline document 23 | 0.020 3000.000 0.000 2.100 70.000 0.100 24 | 0.020 3000.000 0.000 2.100 70.000 0.100 25 | 0.020 1500.000 25.000 2.100 70.000 0.100 26 | 0.020 1500.000 25.000 2.100 70.000 0.100 27 | 0.020 1500.000 25.000 2.100 70.000 0.100 28 | 0.020 4000.000 10.000 3.600 350.000 0.100 29 | 0.020 4000.000 10.000 3.600 350.000 0.100 30 | 0.020 4000.000 10.000 3.600 350.000 0.100 31 | 0.020 4000.000 10.000 3.600 350.000 0.100 32 | 0.020 4000.000 10.000 3.600 350.000 0.100 33 | 0.020 4000.000 10.000 3.600 350.000 0.100 34 | 0.020 4000.000 10.000 3.600 350.000 0.100 35 | 0.020 4000.000 10.000 3.600 350.000 0.100 36 | 0.020 4000.000 10.000 3.600 350.000 0.100 37 | 0.020 4000.000 10.000 3.600 350.000 0.100 38 | 0.020 4000.000 10.000 3.600 350.000 0.100 39 | 0.020 4000.000 10.000 3.600 350.000 0.100 40 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 ---- latent hardening matrix. 41 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 42 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 43 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 44 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 45 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 46 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 47 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 48 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 49 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 50 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 51 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 52 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 53 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 54 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 55 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 56 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 57 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 58 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 59 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 60 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 61 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 62 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 63 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 64 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 65 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 66 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 67 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 68 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 69 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 70 | -------------------------------------------------------------------------------- /docs/CPFEM_guidelines_from_Dim/prein_labelled pete 18 systems.txt: -------------------------------------------------------------------------------- 1 | 15 ----divisions x 2 | 15 ----divisions y 3 | 15 ----divisions z 4 | 1 ----length of element in x 5 | 1 ----length of element in y 6 | 1 ----length of element in z 7 | 2 ----element shape 8 | 3 ----boundary behaviour, 3 indicates just x faces constrained 9 | 18 ----number of slip systems 10 | 4 ----option for orientation set input. 4 means input a texture (.ori) file. 11 | 1 ---- no. of orientations sets 12 | 1 ---- fraction of orientations to be used 13 | ---- necessary space 14 | zry4_ann_3375 ---- name of .ori file without extension. 15 | ----space 16 | 1 ---- number of property sets, i.e., the number of orientation files you are inputting 17 | ---- space 18 | ZrRD2 ---- name of material .fmt file excluding extension 19 | n ---- n for no to making initial slip resistances equal 20 | 55.000 ---- list of 18 initial slip resistances for each of the systems defined in .fmt file 21 | 55.000 22 | 55.000 23 | 55.000 24 | 55.000 25 | 55.000 26 | 330.000 27 | 330.000 28 | 330.000 29 | 330.000 30 | 330.000 31 | 330.000 32 | 330.000 33 | 330.000 34 | 330.000 35 | 330.000 36 | 330.000 37 | 330.000 38 | n ---- n: no to setting a fraction to elastic only. 39 | -0.001 ---- size and direction of strain increment, negative indicates compression 40 | 500.000 ---- denotes the total number of increments, and therefore the total strain 41 | n ---- set tied node conditions, no. 42 | n ---- 43 | n ---- 44 | R300_ratio_16_higher_res ---- name of file called to determine which increments to write output files for 45 | -------------------------------------------------------------------------------- /docs/CPFEM_introduction.doc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabortimar/CPFEM_code/f01e68becd0d01b774f864e8c83bb9d1081ae282/docs/CPFEM_introduction.doc -------------------------------------------------------------------------------- /docs/Hardening.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabortimar/CPFEM_code/f01e68becd0d01b774f864e8c83bb9d1081ae282/docs/Hardening.pdf -------------------------------------------------------------------------------- /sample_input_files/aluminium2.fmt: -------------------------------------------------------------------------------- 1 | 6 2 | 12 3 | 1.59e-5 1.59e-5 1.59e-5 -0.58e-5 -0.58e-5 -0.58e-5 3.53e-5 3.53e-5 3.53e-5 4 | 0 0 0 0 0 0 0 0 0 0 0 0 5 | 0.000000 0.707107 -0.707107 0.577350 0.577350 0.577350 6 | -0.707107 0.000000 0.707107 0.577350 0.577350 0.577350 7 | 0.707107 -0.707107 0.000000 0.577350 0.577350 0.577350 8 | 0.000000 0.707107 0.707107 0.577350 0.577350 -0.577350 9 | -0.707107 0.000000 -0.707107 0.577350 0.577350 -0.577350 10 | 0.707107 -0.707107 0.000000 0.577350 0.577350 -0.577350 11 | 0.000000 0.707107 -0.707107 -0.577350 0.577350 0.577350 12 | 0.707107 0.000000 0.707107 -0.577350 0.577350 0.577350 13 | -0.707107 -0.707107 0.000000 -0.577350 0.577350 0.577350 14 | 0.000000 -0.707107 -0.707107 0.577350 -0.577350 0.577350 15 | -0.707107 0.000000 0.707107 0.577350 -0.577350 0.577350 16 | 0.707107 0.707107 0.000000 0.577350 -0.577350 0.577350 17 | 0.02 0.0 0.0 12.0 80.0 0.0 18 | 0.02 0.0 0.0 12.0 80.0 0.0 19 | 0.02 0.0 0.0 12.0 80.0 0.0 20 | 0.02 0.0 0.0 12.0 80.0 0.0 21 | 0.02 0.0 0.0 12.0 80.0 0.0 22 | 0.02 0.0 0.0 12.0 80.0 0.0 23 | 0.02 0.0 0.0 12.0 80.0 0.0 24 | 0.02 0.0 0.0 12.0 80.0 0.0 25 | 0.02 0.0 0.0 12.0 80.0 0.0 26 | 0.02 0.0 0.0 12.0 80.0 0.0 27 | 0.02 0.0 0.0 12.0 80.0 0.0 28 | 0.02 0.0 0.0 12.0 80.0 0.0 29 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 30 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 31 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 32 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 33 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 34 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 35 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 36 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 37 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 38 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 39 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 40 | 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 41 | 42 | -------------------------------------------------------------------------------- /sample_input_files/dirname: -------------------------------------------------------------------------------- 1 | "/home/mclssgt2/Projects/CPFEM/simulations/Materials/" 2 | "/home/mclssgt2/Projects/CPFEM/simulations/Orientations/" 3 | "" 4 | "" 5 | "/home/mclssgt2/bin/" 6 | -------------------------------------------------------------------------------- /sample_input_files/fafcdf.dat: -------------------------------------------------------------------------------- 1 | 1.e-3 100 20.0 1.0 2 | 1.e+20 1.e-1 10.0 3 | 1.e-5 5.e-1 5.e-1 4 | -------------------------------------------------------------------------------- /sample_input_files/fe_input2.txt: -------------------------------------------------------------------------------- 1 | Sim 2 | 3 | 49 4 | 5 | 6 | 10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 320 330 340 350 360 370 380 390 400 410 420 430 440 450 460 470 480 490 -------------------------------------------------------------------------------- /sample_input_files/fs3pre_inputs.txt: -------------------------------------------------------------------------------- 1 | 10 2 | 10 3 | 10 4 | 1 5 | 1 6 | 1 7 | 2 8 | 2 9 | 12 10 | 4 11 | 1 12 | 1 13 | 14 | random-E 15 | 16 | 1 17 | 18 | aluminium2 19 | y 20 | 20.000 21 | n 22 | 0.0005 23 | 0.0005 24 | 1000.000 25 | 1 26 | 1 27 | n 28 | n 29 | n 30 | Sim 31 | -------------------------------------------------------------------------------- /src/csvmkr/csvmkr.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! CVSMKR ! 4 | ! Joao Fonseca ! 5 | ! ! 6 | !-----------------------------------------------------------------------! 7 | ! Post-pocessor: reads fst files and writes csv files ! 8 | ! ! 9 | ! ! 10 | !***********************************************************************! 11 | 12 | PROGRAM CVSMKR 13 | 14 | IMPLICIT NONE 15 | INTEGER(4) type 16 | 17 | CALL FPREAD() 18 | WRITE(*,'(/,10X,"Element (1,default) or Gauss point (2) values?")') 19 | READ(*,*) type 20 | IF (type.EQ.2) THEN 21 | CALL GPSTATE() 22 | ELSE 23 | CALL ELSTATE() 24 | END IF 25 | 26 | CALL POWER() 27 | 28 | END PROGRAM 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/csvmkr/data_in.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE FPREAD ! 4 | !-----------------------------------------------------------------------! 5 | ! Reads data file for FASPLOT3 ! 6 | !-----------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************! 9 | SUBROUTINE FPREAD(f_name) 10 | 11 | USE FAS_COM 12 | 13 | IMPLICIT NONE 14 | 15 | LOGICAL(4) l_file 16 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe, res, twinlim 17 | REAL(4) twinprob 18 | 19 | INTEGER(4), DIMENSION(1:20):: nss 20 | 21 | CHARACTER(100) :: f_name 22 | INTEGER(4), PARAMETER:: in= 51 23 | 24 | !-----open file to read here-------!!!!!!!! 25 | 26 | 27 | CALL INPFILE( in, l_file) 28 | !IF ( .NOT. l_file) CALL FAFERR(501)  29 | 30 | READ(in, ERR=991) ninc ! increment number 31 | ninc0=ninc+1 32 | 33 | READ(in,ERR=991) nlmnt, nnod, ngps, nsv ! number of elements, nodes, gauss points; nsv: number of slip systems + 3 34 | WRITE (*,*) nlmnt,maxels,nnod,maxnod,ngps,maxgps 35 | IF( nlmnt.GT.maxels .OR. nnod.GT.maxnod .OR. ngps.GT.maxgps) STOP 36 | 37 | !------------------------read element definitions 38 | DO i= 1, nlmnt 39 | READ(in,ERR=991) le(i), lt(i), nde, npe 40 | READ(in,ERR=991)(ln(j,i), j= 1, nde) 41 | READ(in,ERR=991)(lg(j,i), j= 1, npe) 42 | nd(i)=nde 43 | np(i)=npe 44 | END DO 45 | 46 | !----------------------exclude zero integration point ( tie) elements 47 | i=1 48 | DO WHILE ( i .LE. nlmnt) 49 | IF (np(i).EQ.0) THEN 50 | nlmnt= nlmnt-1 51 | IF ( i.LT.nlmnt) THEN 52 | DO j=i,nlmnt 53 | le(j)=le(j+1) 54 | lt(j)=lt(j+1) 55 | nd(j)=nd(j+1) 56 | np(j)=np(j+1) 57 | ln(1:nd(j),j)=ln(1:nd(j),j+1) 58 | lg(1:np(j),j)=lg(1:np(j),j+1) 59 | END DO 60 | END IF 61 | ELSE 62 | i= i + 1 63 | 64 | END IF 65 | 66 | END DO 67 | 68 | !----------------------read nodal variables 69 | DO i= 1, nnod 70 | i3= 3*i 71 | i2= i3 - 1 72 | i1= i2 - 1 73 | READ(in,ERR=991) ib(i) 74 | READ(in,ERR=991) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 75 | READ(in,ERR=991) fc(i1), fc(i2), fc(i3) 76 | 77 | END DO 78 | 79 | !---------------------read integration point variables 80 | DO i= 1, ngps 81 | READ(in,ERR=991) eps(i), dep(i) 82 | READ(in,ERR=991) ( sv(j,i), j= 1, nsv) 83 | READ(in,ERR=991) (dsv(j,i), j= 1, nsv) 84 | READ(in,ERR=991) (ep(j,i), j= 1, 6) 85 | READ(in,ERR=991) (de(j,i), j= 1, 6) 86 | READ(in,ERR=991) (st(j,i), j= 1, 6) 87 | READ(in,ERR=991) (ds(j,i), j= 1, 6) 88 | READ(in,ERR=991) (rt(j,i), j= 1, 3) 89 | READ(in,ERR=991) (dr(j,i), j= 1, 3) 90 | END DO 91 | 92 | !----------------read (skip except e) material properties 93 | READ(in) nmatl 94 | DO i= 1, nmatl 95 | READ(in) nss(i) 96 | READ(in) twinlim 97 | READ(in) twinprob 98 | READ(in) e(1:9,i) 99 | 100 | DO j= 1, nss(i) 101 | READ(in) 102 | END DO 103 | 104 | DO j= 1, nss(i) 105 | READ(in) 106 | END DO 107 | 108 | DO j=1,nss(i) 109 | READ(in) 110 | END DO 111 | 112 | END DO 113 | 114 | !---------------------------read (skip) surface properties 115 | READ(in) 116 | 117 | !---------------------------------read control data 118 | READ(in,ERR=991) ninc1, nxs, nfs 119 | DO i= 1, ninc1 120 | READ(in,ERR=991) tiem(i) 121 | IF ( nxs .GT. 0 ) THEN 122 | DO j= 1, nxs 123 | READ(in,ERR=991) ( x_spec(k,j,i), k= 1,15) 124 | END DO 125 | ENDIF 126 | IF ( nfs .GT. 0 ) THEN 127 | DO j= 1, nfs 128 | READ(in,ERR=991) ( f_spec(k,j,i), k= 1, 3) 129 | END DO 130 | ENDIF 131 | END DO 132 | 133 | l_file= .TRUE. ! Set success flag to true 134 | 135 | 136 | 991 CONTINUE ! -any failure by-passes flag 137 | 138 | 139 | CLOSE(IN) 140 | 141 | 142 | END SUBROUTINE FPREAD 143 | 144 | 145 | 146 | !***********************************************************************! 147 | ! ! 148 | ! SUBROUTINE INPFILE ! 149 | !-----------------------------------------------------------------------! 150 | ! Routine to OPEN FASOLT3 input file ! 151 | ! ! 152 | !-----------------------------------------------------------------------! 153 | !Arguments:IN INTEGER; READ channel number ! 154 | !L_FILE LOGICAL; TRUE if file opened ok ! 155 | !-----------------------------------------------------------------------! 156 | ! ! 157 | !***********************************************************************! 158 | 159 | 160 | 161 | SUBROUTINE INPFILE(in,l_file) 162 | IMPLICIT none 163 | LOGICAL(4) :: l_file 164 | INTEGER :: in,ierr 165 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3, dir4 166 | CHARACTER(4) :: ext 167 | 168 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 169 | IF ( ierr .EQ. 0 ) THEN 170 | READ(in,*) dir1,dir2,dir3,dir4 171 | dir=dir3 172 | ELSE 173 | WRITE(*,'("No dirname file found. Path is current directory.")') 174 | dir='' 175 | END IF 176 | CLOSE (in) 177 | 178 | 179 | WRITE(*,'("Name of FASOLT file (no extension): ")') 180 | ext=".frs" 181 | CALL check_file(f_name,ext,dir) 182 | OPEN(in ,FILE=f_name ,STATUS='OLD', FORM= 'UNFORMATTED', & 183 | & ACCESS= 'SEQUENTIAL', IOSTAT=ierr) 184 | IF ( ierr .EQ. 0 ) THEN 185 | l_file = .TRUE. 186 | ELSE 187 | WRITE(*,'("Could not open results file! ")') 188 | l_file = .FALSE. 189 | END IF 190 | END SUBROUTINE INPFILE 191 | 192 | 193 | !***********************************************************************! 194 | ! ! 195 | ! SUBROUTINE check_file ! 196 | !-----------------------------------------------------------------------! 197 | ! Routine to help with inputing file to open ! 198 | ! ! 199 | !-----------------------------------------------------------------------! 200 | !Arguments:f_name ext dir; to define file and path ! 201 | !here LOGICAL; TRUE if file exhists ! 202 | !-----------------------------------------------------------------------! 203 | ! ! 204 | !***********************************************************************! 205 | 206 | SUBROUTINE check_file(f_name,ext,dir) 207 | IMPLICIT none 208 | CHARACTER(100), INTENT(OUT) :: f_name 209 | CHARACTER(100), INTENT(IN) :: dir 210 | CHARACTER(4), INTENT(IN) :: ext 211 | INTEGER :: i 212 | LOGICAL :: here 213 | 214 | DO i=1,3 215 | READ(*,*) f_name 216 | f_name=TRIM(dir)//TRIM(f_name)//TRIM(ext) 217 | INQUIRE(FILE=f_name, EXIST=here) 218 | 219 | IF (here) THEN 220 | EXIT 221 | ELSE IF (i .LT. 3) THEN 222 | WRITE (*,'("File not found. Try again.")') 223 | CYCLE 224 | ELSE 225 | WRITE (*,'("File not found. Exiting.")') 226 | STOP 227 | END IF 228 | END DO 229 | 230 | END SUBROUTINE check_file 231 | 232 | -------------------------------------------------------------------------------- /src/csvmkr/fas-con-mod.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************************! 2 | ! ! 3 | ! MODULE FAS_COM ! 4 | !-----------------------------------------------------------------------------------! 5 | ! Module containing the type and array declarations for the main FASOLT variables ! 6 | !-----------------------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************************! 9 | MODULE FAS_COM 10 | 11 | 12 | INTEGER, PARAMETER:: maxnod= 50000, maxdof=150000, maxels= 8000 13 | INTEGER, PARAMETER:: maxgps=64000, maxinc= 2000, maxsvs= 63 14 | INTEGER, PARAMETER:: maxofd= 1000 15 | 16 | INTEGER(4) nlmnt, nnod, ngps, ninc, ninc0, ninc1, nsv, inc, nxs, nfs, nmpar, maxit 17 | 18 | INTEGER(4), DIMENSION( 1:maxels) :: le, lt, nd, np 19 | INTEGER(4), DIMENSION( 1:20, 1:maxels) :: ln 20 | INTEGER(4), DIMENSION( 1:8, 1:maxels) :: lg 21 | INTEGER(4), DIMENSION( 1:maxnod) :: ib 22 | REAL(4), DIMENSION( 1:maxdof) :: x, dx, fc, ddx 23 | REAL(4), DIMENSION( 1:maxgps) :: eps, dep 24 | REAL(4), DIMENSION( 1:6, 1:maxgps) :: st, ep, ds, de 25 | REAL(4), DIMENSION( 1:3, 1:maxgps) :: rt, dr 26 | REAL(4), DIMENSION( 1:maxsvs, 1:maxgps) :: sv, dsv 27 | 28 | REAL(4), DIMENSION( 1:maxinc) :: tiem 29 | REAL(4), DIMENSION( 1:15, 1:99, 1:maxinc) :: x_spec 30 | REAL(4), DIMENSION( 1:3, 1:99, 1:maxinc) :: f_spec 31 | 32 | !------------------------------------------elastic contants 33 | INTEGER(4) nmatl 34 | REAL(4), DIMENSION(1:9,1:20)::e 35 | 36 | !------------------------------------------plot entities 37 | INTEGER(4) n_point, n_ent 38 | INTEGER(4), DIMENSION(0:3, 1:10*maxnod):: entlist 39 | REAL(4), DIMENSION(1:3, 1: 2*maxnod):: point 40 | 41 | !-------------------------------------------------restrictions 42 | INTEGER(4) nelclass 43 | LOGICAL(4), DIMENSION(1:maxels):: elrestrict 44 | LOGICAL(4), DIMENSION(1:maxnod):: ndrestrict 45 | INTEGER(4), DIMENSION(1:maxels):: elclass 46 | 47 | !--------------------------------------------'contouring' 48 | CHARACTER clable*30 49 | INTEGER(4) l_contour 50 | REAL(4) gpv_zero, gpv_scale 51 | REAL(4), DIMENSION(1:maxgps):: gpvalue 52 | REAL(4), DIMENSION(1:maxnod)::nod_cv 53 | 54 | 55 | END MODULE FAS_COM 56 | -------------------------------------------------------------------------------- /src/csvmkr/fspl_orir.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************************! 2 | ! ! 3 | ! REAL(4) FUNCTION MISORI ! 4 | !-----------------------------------------------------------------------------------! 5 | ! Misorientation angle ! 6 | ! ! 7 | !***********************************************************************************! 8 | REAL(4) FUNCTION MISORI( isym, ea_ref, ea_val ) 9 | 10 | IMPLICIT NONE 11 | INTEGER(4) isym 12 | REAL(4) ea_ref, ea_val, a, b, trmax, QTNTCE 13 | DIMENSION ea_ref(1:3), ea_val(1:3), a(0:3), b(0:3) 14 | 15 | CALL QTNEUL( ea_ref(1), ea_ref(2), ea_ref(3), a) 16 | CALL QTNEUL( ea_val(1), ea_val(2), ea_val(3), b) 17 | 18 | CALL SYM_NEAR( isym, a, b, trmax) 19 | 20 | MISORI= 2.*ACOS( trmax) 21 | 22 | END FUNCTION 23 | 24 | !*******************************************************************************! 25 | ! ! 26 | ! SUBROUTINE QTNEUL(ph1,phi,ph2,x) ! 27 | !-------------------------------------------------------------------------------! 28 | ! Returns the Euler-symmetrics (0:3) given the Euler angles ! 29 | ! ! 30 | !*******************************************************************************! 31 | SUBROUTINE QTNEUL(ph1,phi,ph2,x) 32 | 33 | IMPLICIT NONE 34 | REAL(4) ph1, phi, ph2, x, c_half, s_half 35 | DIMENSION x(0:3) 36 | 37 | c_half= COS( phi/2.) 38 | s_half= SIN( phi/2.) 39 | 40 | x(0)= c_half * COS( (ph1+ph2)/2. ) 41 | x(1)= -s_half * COS( (ph2-ph1)/2. ) 42 | x(2)= s_half * SIN( (ph2-ph1)/2. ) 43 | x(3)= -c_half * SIN( (ph1+ph2)/2. ) 44 | 45 | IF ( x(0) .LT. 0. ) x= -x ! ensure in positive hemisphere 46 | 47 | 48 | END SUBROUTINE QTNEUL 49 | 50 | !*******************************************************************************! 51 | ! ! 52 | ! SUBROUTINE EULQTN(a,ph1,phi,ph2) ! 53 | !-------------------------------------------------------------------------------! 54 | ! Returns the Euler angles given the Euler symmetrics, a(0:3) ! 55 | ! ! 56 | !*******************************************************************************! 57 | SUBROUTINE EULQTN(a,ph1,phi,ph2) 58 | 59 | IMPLICIT NONE 60 | REAL(4) a, ph1, phi, ph2 61 | DIMENSION a(0:3) 62 | 63 | REAL(4) cphi 64 | 65 | cphi= 1. -2.*(a(1)*a(1)+a(2)*a(2)) 66 | IF ( cphi .GT. -1.) THEN 67 | phi= ACOS( cphi) 68 | ELSE 69 | phi= 3.14159265359 70 | END IF 71 | 72 | IF ( ABS(cphi) .GE. 1 ) THEN 73 | ph1= 0.5*ATAN2( 2.*(a(1)*a(2)-a(0)*a(3)) ,1.-2.*(a(2)*a(2)+a(3)*a(3))) 74 | ph2= ph1 75 | ELSE 76 | ph1= ATAN2( (a(1)*a(3)-a(0)*a(2)), -(a(2)*a(3)+a(0)*a(1)) ) 77 | ph2= ATAN2( (a(1)*a(3)+a(0)*a(2)), (a(2)*a(3)-a(0)*a(1)) ) 78 | END IF 79 | 80 | END SUBROUTINE EULQTN 81 | 82 | !*******************************************************************************! 83 | ! ! 84 | ! REAL FUNCTION QTNTCE(a,b) ! 85 | !-------------------------------------------------------------------------------! 86 | ! Returns the scalar product two Euler-symmetrics a(0:3), b(0:3). ! 87 | ! -note the relationship with the first component of a':b. ! 88 | ! ( see QTNPRD and QTNTRP code ) ! 89 | ! ! 90 | !*******************************************************************************! 91 | REAL FUNCTION QTNTCE(a,b) 92 | 93 | IMPLICIT NONE 94 | INTEGER(4) i 95 | REAL(4) a, b, sum 96 | DIMENSION a(0:3), b(0:3) 97 | 98 | sum= 0. 99 | DO i= 0, 3 100 | sum= sum + a(i)*b(i) 101 | END DO 102 | 103 | QTNTCE= sum 104 | 105 | END FUNCTION QTNTCE 106 | 107 | !*******************************************************************************! 108 | ! ! 109 | ! SUBROUTINE QTNNRM(a, norm) ! 110 | !-------------------------------------------------------------------------------! 111 | ! Returns the normalised Euler symmetrics (0:3) and the normalisation factor. ! 112 | ! Note that the normalisation can be used to give 'inverse variance' ! 113 | ! ! 114 | !*******************************************************************************! 115 | SUBROUTINE QTNNRM(a, norm) 116 | 117 | IMPLICIT NONE 118 | REAL(4) a, norm, QTNTCE 119 | DIMENSION a(0:3) 120 | 121 | norm= 1./ SQRT( QTNTCE(a,a) ) 122 | 123 | a= norm * a 124 | 125 | END SUBROUTINE QTNNRM 126 | 127 | !*******************************************************************************! 128 | ! ! 129 | ! SUBROUTINE QTNPRD(a,b,c) ! 130 | !-------------------------------------------------------------------------------! 131 | ! Forms the product c = a:b, in Euler-symmetrics (0:3) ! 132 | ! ! 133 | !*******************************************************************************! 134 | SUBROUTINE QTNPRD(a,b,c) 135 | 136 | IMPLICIT NONE 137 | REAL(4) a, b, c 138 | DIMENSION a(0:3), b(0:3), c(0:3) 139 | 140 | c(0)= a(0)*b(0) - a(1)*b(1) - a(2)*b(2) - a(3)*b(3) 141 | c(1)= a(0)*b(1) + a(1)*b(0) + a(2)*b(3) - a(3)*b(2) 142 | c(2)= a(0)*b(2) - a(1)*b(3) + a(2)*b(0) + a(3)*b(1) 143 | c(3)= a(0)*b(3) + a(1)*b(2) - a(2)*b(1) + a(3)*b(0) 144 | 145 | END SUBROUTINE QTNPRD 146 | 147 | !*******************************************************************************! 148 | ! ! 149 | ! SUBROUTINE SYM_NEAR( isym, x, y, trmax) ! 150 | !-------------------------------------------------------------------------------! 151 | ! Converts y(0:3) to the symmetry (set by isym) variant closest to x(0:3) ! 152 | !...............................................................................! 153 | ! symmetry codes: ! 154 | ! 0 triclinic ! 155 | ! 1 monoclinic ! 156 | ! 2 orthorhombic ! 157 | ! 3 trigonal ! 158 | ! 4 tetragonal ! 159 | ! 5 hexagonal ! 160 | ! 6 cubic ! 161 | ! ! 162 | !*******************************************************************************! 163 | SUBROUTINE SYM_NEAR( isym, x, y, trmax) 164 | 165 | IMPLICIT NONE 166 | INTEGER(4) isym, symon, i 167 | REAL(4) x, y, a, b, asym, amin, trace, trmax 168 | DIMENSION x(0:3), y(0:3), a(0:3), b(0:3), amin(0:3) 169 | 170 | REAL(4) QTNTCE 171 | 172 | COMMON/ SYMQCF/ asym(0:3, 1:30 ), symon(1:30,0:6) ! symmetry operation data 173 | 174 | trmax= QTNTCE(x,y) ! initialise cos(w/2) 175 | amin= y 176 | 177 | DO i= 2, 30 178 | IF ( symon(i, isym) .EQ. 1 ) THEN ! check if symmetry in class 179 | 180 | a(0:3) = asym(0:3, i) 181 | CALL QTNPRD(a,y,b) 182 | 183 | IF ( b(0) .LT. 0.) b= -b ! ensure in positive hemisphere 184 | 185 | trace= QTNTCE(x,b) ! generate/test cos(w/2) 186 | 187 | IF ( trace .GT. trmax) THEN 188 | trmax= trace 189 | amin= b 190 | END IF 191 | END IF 192 | END DO 193 | 194 | y= amin 195 | 196 | END SUBROUTINE SYM_NEAR 197 | 198 | !*******************************************************************************! 199 | ! ! 200 | ! BLOCK DATA SYMQTN ! 201 | !-------------------------------------------------------------------------------! 202 | ! Data for symmetry operations expressed as Euler symmetrics (0:3) and switch ! 203 | ! codes (1 for on, 0 for off) for their application in the 7 point groups. ! 204 | !-------------------------------------------------------------------------------! 205 | ! symmetry codes: ! 206 | ! 0 triclinic ! 207 | ! 1 monoclinic ! 208 | ! 2 orthorhombic ! 209 | ! 3 trigonal ! 210 | ! 4 tetragonal ! 211 | ! 5 hexagonal ! 212 | ! 6 cubic ! 213 | ! ! 214 | !*******************************************************************************! 215 | BLOCK DATA SYMQTN 216 | 217 | IMPLICIT NONE 218 | INTEGER(4) symon, i 219 | REAL(4) asym 220 | 221 | COMMON/ SYMQCF/ asym(0:3, 1:30 ), symon(1:30,0:6) 222 | 223 | DATA (asym(i, 1),i= 0, 3)/ 1.0, 0.0, 0.0, 0.0 / ! identity 224 | 225 | DATA (asym(i, 2),i= 0, 3)/ 0.7071068, 0.7071068, 0.0, 0.0 / ! 90 [ 1 0 0] 226 | DATA (asym(i, 3),i= 0, 3)/ 0.0, 1.0, 0.0, 0.0 / ! 180 [ 1 0 0] 227 | DATA (asym(i, 4),i= 0, 3)/ 0.7071068,-0.7071068, 0.0, 0.0 / ! 260 [ 1 0 0] 228 | 229 | DATA (asym(i, 5),i= 0, 3)/ 0.7071068, 0.0, 0.7071068, 0.0 / ! 90 [ 0 1 0] 230 | DATA (asym(i, 6),i= 0, 3)/ 0.0, 0.0, 1.0, 0.0 / ! 180 [ 0 1 0] 231 | DATA (asym(i, 7),i= 0, 3)/ 0.7071068, 0.0,-0.7071068, 0.0 / ! 270 [ 0 1 0] 232 | 233 | DATA (asym(i, 8),i= 0, 3)/ 0.7071068, 0.0, 0.0, 0.7071068 / ! 90 [ 0 0 1] 234 | DATA (asym(i, 9),i= 0, 3)/ 0.0, 0.0, 0.0, 1.0 / ! 180 [ 0 0 1] 235 | DATA (asym(i,10),i= 0, 3)/ 0.7071068, 0.0, 0.0,-0.7071068 / ! 270 [ 0 0 1] 236 | 237 | DATA (asym(i,11),i= 0, 3)/0.0, 0.7071068, 0.7071068, 0.0 / ! 180 [ 1 1 0] 238 | DATA (asym(i,12),i= 0, 3)/0.0,-0.7071068, 0.7071068, 0.0 / ! 180 [-1 1 0] 239 | 240 | DATA (asym(i,13),i= 0, 3)/0.0, 0.7071068, 0.0, 0.7071068 / ! 180 [ 1 0 1] 241 | DATA (asym(i,14),i= 0, 3)/0.0,-0.7071068, 0.0, 0.7071068 / ! 180 [-1 0 1] 242 | 243 | DATA (asym(i,15),i= 0, 3)/0.0, 0.0, 0.7071068, 0.7071068 / ! 180 [ 0 1 1] 244 | DATA (asym(i,16),i= 0, 3)/0.0, 0.0,-0.7071068, 0.7071068 / ! 180 [ 0-1 1] 245 | 246 | !-----------------cubic {111} triads 247 | DATA (asym(i,17),i= 0, 3)/ 0.5, 0.5, 0.5, 0.5/ ! 120 [ 1 1 1] 248 | DATA (asym(i,18),i= 0, 3)/ 0.5, -0.5,-0.5,-0.5/ ! 240 [ 1 1 1] 249 | 250 | DATA (asym(i,19),i= 0, 3)/ 0.5,-0.5, 0.5, 0.5/ ! 120 [-1 1 1] 251 | DATA (asym(i,20),i= 0, 3)/ 0.5, 0.5,-0.5,-0.5/ ! 240 [-1 1 1] 252 | 253 | DATA (asym(i,21),i= 0, 3)/ 0.5, 0.5,-0.5, 0.5/ ! 120 [ 1-1 1] 254 | DATA (asym(i,22),i= 0, 3)/ 0.5,-0.5, 0.5,-0.5/ ! 240 [ 1-1 1] 255 | 256 | DATA (asym(i,23),i= 0, 3)/ 0.5, 0.5, 0.5,-0.5/ ! 120 [ 1 1-1] 257 | DATA (asym(i,24),i= 0, 3)/ 0.5,-0.5,-0.5, 0.5/ ! 240 [ 1 1-1] 258 | 259 | !-------------hexgonal hexads, include 180 [ 0 0 1]: subset for trigonal 260 | DATA (asym(i,25),i= 0, 3)/ 0.866254, 0.0, 0.0, 0.5 / ! 60 [ 0 0 1] 261 | DATA (asym(i,26),i= 0, 3)/ 0.5, 0.0, 0.0, 0.866254 / ! 120 [ 0 0 1] 262 | DATA (asym(i,27),i= 0, 3)/ 0.5, 0.0, 0.0,-0.866254 / ! 240 [ 0 0 1] 263 | DATA (asym(i,28),i= 0, 3)/ 0.866354, 0.0, 0.0,-0.5 / ! 300 [ 0 0 1] 264 | 265 | !--------------hexagonal diads, use with 180 [ 1 0 0] 266 | DATA (asym(i,29),i= 0, 3)/ 0.0,-0.5, 0.866254, 0.0 / ! 180 [ 0 1-1 0] 267 | DATA (asym(i,30),i= 0, 3)/ 0.0,-0.5,-0.866254, 0.0 / ! 180 [ 0-1 1 0] 268 | 269 | !---------------------------------on/off codes for point groups 270 | DATA (symon(i,0),i=1,30)/1,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 271 | & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 / !triclinic 272 | 273 | DATA (symon(i,1),i=1,30)/1,0,1,0,0,0,0,0,0,0,0,0,0,0,0, & 274 | & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 / !monoclinic 275 | 276 | DATA (symon(i,2),i=1,30)/1,0,1,0,0,1,0,0,1,0,0,0,0,0,0, & 277 | & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 / !orthorhombic 278 | 279 | DATA (symon(i,3),i=1,30)/1,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 280 | & 0,0,0,0,0,0,0,0,0,0,1,1,0,0,0 / !trigonal 281 | 282 | DATA (symon(i,4),i=1,30)/1,0,1,0,0,1,0,1,1,1,1,1,0,0,0, & 283 | & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 / !tetragonal 284 | 285 | DATA (symon(i,5),i=1,30)/1,0,1,0,0,0,0,0,1,0,0,0,0,0,0, & 286 | & 0,0,0,0,0,0,0,0,0,1,1,1,1,1,1 / !hexagonal 287 | 288 | DATA (symon(i,6),i=1,30)/1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & 289 | & 1,1,1,1,1,1,1,1,1,0,0,0,0,0,0 / !cubic 290 | 291 | END BLOCK DATA SYMQTN 292 | -------------------------------------------------------------------------------- /src/csvmkr/makefile: -------------------------------------------------------------------------------- 1 | objects= fas-con-mod.o data_in.o data_out.o fspl_orir.o csvmkr.o 2 | 3 | FC=ifort 4 | FFLAGS= -i-static -O3 5 | 6 | %.o : %.f90 7 | $(FC) -c $(FFLAGS) $< -o $@ 8 | 9 | csvmkr:$(objects) 10 | ifort $(FFLAGS) -o csvmkr $(objects) 11 | 12 | fas-con-mod.o:fas-con-mod.f90 13 | 14 | fspl_orir.o:fspl_orir.f90 15 | 16 | csvmkr.o:csvmkr.f90 17 | 18 | data_in.o:data_in.f90 19 | 20 | data_out.o:data_out.f90 21 | 22 | .PHONY: clean 23 | 24 | clean: 25 | rm csvmkr $(objects) fas_com.mod 26 | install: 27 | cp csvmkr /home/fonseca/bin 28 | -------------------------------------------------------------------------------- /src/fasolt/Bconds.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE SUVALS ! 4 | !-----------------------------------------------------------------------! 5 | ! Evaluation and assembly of boundary conditions and surface ! 6 | ! related quantities for mechanical problem. ! 7 | !-----------------------------------------------------------------------! 8 | ! BC codes: ib code formulated as follows: ! 9 | ! decimal ccbbaa ! 10 | ! a: 0 nul, 1 surface node specifier ! 11 | ! b: 0 nul, 1....99 Kinematic constraints ! 12 | ! c: 0 nul, 1....99 Specified Loads ! 13 | ! ! 14 | ! Notes: ! 15 | ! The kinematic stiffness is added: this allows freedoms ! 16 | ! (9, i_kin, inc): 1,6 'stiffness', 7..9 spec. dx ! 17 | ! ! 18 | !***********************************************************************! 19 | SUBROUTINE SUVALS 20 | 21 | USE FAS_COM ! FASOLT main variables declaration 22 | 23 | IMPLICIT NONE 24 | 25 | INTEGER(4) i, j, k, l, ndof, idof, inod, ibc, & 26 | & i_kin, i_spf, row, loctn, point 27 | REAL(4) xsloc, xspec, d_spec, sum 28 | 29 | DIMENSION point( 1:3, 1:3), xsloc(1:15) 30 | DIMENSION xspec( 1:3), d_spec(1:3,1:3) 31 | 32 | !--------------------------------------Pointer to UT 3x3 array 33 | DATA ((point(i,j), i=1,3), j=1,3)/1,2,4, 2,3,5, 4,5,6/ 34 | 35 | !------------------------------Put current inbalances to r.h.s. vectors 36 | ndof= 3*nnod 37 | ddx(1:ndof)=fc(1:ndof) 38 | 39 | 40 | DO inod= 1, nnod 41 | ibc= ib(inod) 42 | IF ( ibc .GE. 100 ) THEN ! There is a boundary condition 43 | idof= 3*inod-3 44 | 45 | i_kin= MOD( ibc/100, 100) 46 | IF ( i_kin .GT. 0 ) THEN ! Kinematic constraint 47 | 48 | xsloc(1:15)= x_spec(1:15, i_kin, inc) 49 | 50 | IF ( i_kin.LT. 50) THEN ! absolute constraint 51 | xspec(1)= xsloc( 7) 52 | xspec(2)= xsloc(11) 53 | xspec(3)= xsloc(15) 54 | 55 | ELSE ! relative constraint 56 | l= 6 57 | DO j= 1,3 58 | DO k=1,3 59 | l=l+1 60 | d_spec(j,k)= xsloc(l) 61 | END DO 62 | END DO 63 | 64 | DO j= 1, 3 65 | xspec(j)=0. 66 | DO k= 1, 3 67 | xspec(j)= xspec(j) + d_spec(j,k)*( x(idof+k) + dx(idof+k) ) 68 | END DO 69 | END DO 70 | 71 | END IF 72 | 73 | !--------------------------------------augment stiffness, apply displacement 74 | DO i= 1, 3 75 | 76 | row= idof + i 77 | DO j= 1, 3 78 | IF ( j .NE. i ) THEN 79 | k=2 80 | DO WHILE( idof+j .NE. is(k, row) ) 81 | k=k+1 82 | END DO 83 | ELSE 84 | k=1 85 | END IF 86 | ss(k, row)= ss(k, row) +(efix*xsloc(point(i,j))) 87 | END DO 88 | 89 | sum=0. 90 | DO j= 1, 3 91 | sum=sum + efix* xsloc(point(i,j)) * ( dx(idof+j) -xspec(j) ) 92 | END DO 93 | 94 | ddx( row)= ddx( row) + sum 95 | 96 | END DO 97 | 98 | END IF 99 | 100 | i_spf= MOD( ibc/10000, 100) 101 | IF ( i_spf .GT. 0 ) THEN ! Specified load 102 | 103 | DO i= 1, 3 104 | ddx( idof+i)= ddx( idof+i) + f_spec( i, i_spf, inc) 105 | END DO 106 | 107 | END IF 108 | 109 | END IF 110 | END DO 111 | 112 | 113 | END SUBROUTINE SUVALS -------------------------------------------------------------------------------- /src/fasolt/Cpstrs.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! Fasolt3 -cpstrs ! 4 | ! Pete Bate 2000 ! 5 | !-----------------------------------------------------------------------! 6 | ! Crystal plasticity constituitive routine for 3-d FEM ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | 11 | !***********************************************************************! 12 | ! ! 13 | ! SUBROUTINE CPSTRS( jgp, el_comp, de, r, s, t, ep, chi) ! 14 | !-----------------------------------------------------------------------! 15 | ! Routine to give the elasto-plastic stress state for crystal ! 16 | ! plasticity by two levels of iteration, given a reasonable ! 17 | ! estimate of stress state to start with. The plastic strain ! 18 | ! increments and the hardening modulus are returned for use in ! 19 | ! the e-p Jacobian contribution. State variable increments are ! 20 | ! created, on a temporary basis, in this routine and downstream ! 21 | !-----------------------------------------------------------------------! 22 | ! Arguments: jgp INTEGER; Gauss point number ! 23 | ! el_comp REAL ARRAY(6,6); elastic compliances ! 24 | ! de REAL ARRAY(6); Strain increments ! 25 | ! r REAL ARRAY(3); R.B. rotation about x,y,z ! 26 | ! s REAL ARRAY(6); Final stresses ! 27 | ! t REAL ARRAY(6), Initial stress (current axes)! 28 | ! ep REAL ARRAY(6); Plastic strain increments ! 29 | ! chi REAL ARRAY(6,6); Elasto-plastic modulus ! 30 | ! ! 31 | !-----------------------------------------------------------------------! 32 | ! ! 33 | !***********************************************************************! 34 | SUBROUTINE CPSTRS( jgp, el_comp, del, rl, s, t, epl, chi) 35 | 36 | USE FAS_COM ! FASOLT main variables declaration 37 | USE FAS_CPL ! Crystal plasticity variables 38 | 39 | IMPLICIT NONE 40 | 41 | INTEGER(4) jgp ! index of current IP 42 | 43 | LOGICAL(4) l_iter 44 | INTEGER(4) i, j, k, kk, iter, ifail, maxcpsit, iop 45 | REAL(4) dt, ph1, phi, ph2, capfac, gamcap, scale, erepmd, & 46 | & FJ2VOM, sum, dp1, dph, dp2, tolercp, alpha_cps 47 | 48 | REAL(4), DIMENSION( 1:3,1:3):: a 49 | REAL(4), DIMENSION(1:6):: del, epl, s, t, erreps 50 | REAL(4), DIMENSION(1:3):: aug, rl 51 | REAL(4), DIMENSION(1:6,1:6):: el_comp, chi, djac 52 | REAL(4), DIMENSION(1:maxss):: am 53 | 54 | !---------------------------------------Common for sum of iteration error 55 | REAL(4) sumcpiter 56 | COMMON/ CPITER / sumcpiter 57 | 58 | !--Local control data: capfac is max. slip/eff. strain inc, alpha and max. iterations. 59 | DATA capfac/ 6.0/ !4 60 | 61 | alpha_cps= alpha 62 | maxcpsit= maxit 63 | tolercp= toler 64 | 65 | !-----------------Pull down time step, orientation and slip resistances 66 | dt=tiem(inc) 67 | ph1= sv(1,jgp) + dsv(1,jgp) 68 | phi= sv(2,jgp) + dsv(2,jgp) 69 | ph2= sv(3,jgp) + dsv(3,jgp) 70 | DO i= 1, nss(mat_code) 71 | s0(i)= sv(i+3,jgp) 72 | s1(i)= s0(i) + dsv(i+3,jgp) 73 | END DO 74 | 75 | gamcap= capfac*FJ2VOM(.FALSE., del) ! Maximum slip allowed 76 | CALL CTMATRX(ph1,phi,ph2,a,aug) ! Orientation matrix 77 | CALL BTMATRX(a) ! Slip matrix 78 | 79 | !----------------------------------------------Iterate for stress state 80 | iter=0 81 | l_iter= .TRUE. 82 | DO WHILE( l_iter ) 83 | iter=iter+1 84 | !-----------------------------------------------------------Slip stresses 85 | tau(1:nss(mat_code))= MATMUL(TRANSPOSE(b(1:6,1:nss(mat_code))),s) 86 | 87 | !----------------------------------------Slip increment predictor with cap 88 | CALL SLPINI(jgp,dt,am) 89 | CALL SCALE_IT(am,s,gamcap,scale) 90 | 91 | !-------------------Slip increment refinement, resistances and visco-plastic matrix 92 | CALL SLPFTA( dt) 93 | CALL SCALE_IT( am, s, gamcap, scale) 94 | 95 | !------------------------------Current guess at plastic strain inc. 96 | epl= MATMUL(b(1:6,1:nss(mat_code)),gam(1:nss(mat_code))) 97 | 98 | erreps= del - epl -MATMUL( el_comp, ( s - t) ) ! Form the strain inc. error 99 | 100 | !-----------------------------Factor ah matrix, form Jacobian 101 | CALL FACTOR(nsa,ah(1:nsa,1:nsa),ifail) 102 | IF ( ifail .EQ. 1 ) CALL FAFERR(910) 103 | DO i= 1, 6 104 | DO j= 1, 6 105 | DO k= 1, nsa 106 | kk= isa(k) 107 | wks(k)= b(j,kk) 108 | END DO 109 | CALL SOLVER(nsa,ah(1:nsa,1:nsa),wks(1:nsa)) 110 | sum=0. 111 | DO k= 1, nsa 112 | kk= isa(k) 113 | sum= sum + b(i,kk)*wks(k) 114 | END DO 115 | djac(i,j)= sum 116 | END DO 117 | END DO 118 | 119 | djac= djac + el_comp ! Add elastic compliances 120 | 121 | !--------------------------------------------------------Correction to stress 122 | CALL FACTOR(6,djac,ifail) 123 | IF (ifail.EQ.1) CALL FAFERR(910) 124 | CALL SOLVER(6,djac,erreps) 125 | 126 | erepmd= FJ2VOM(.TRUE.,erreps)/FJ2VOM(.TRUE.,s) ! Stress error measure 127 | 128 | !------------------------------------Damping to prevent 'fly-off' 129 | scale= 1./( 1. + alpha_cps * erepmd ) 130 | 131 | DO i=1,6 132 | erreps(i)= scale*erreps(i) 133 | END DO 134 | !-------------------------------------Correct the stress 135 | DO i=1,6 136 | s(i)= s(i) + erreps(i) 137 | END DO 138 | 139 | l_iter = (iter.LT.maxcpsit) .AND. (erepmd.GT.tolercp) ! Test for repeat 140 | 141 | END DO 142 | ! Write slip rates to srate variable: 143 | do iop=1,nss(mat_code) 144 | srate(iop, jgp) = ABS(gam(iop) / dt) 145 | end do 146 | ! (this will be overwritten several times because all this is in the outermost NR loop, 147 | ! but this is the only way...) 148 | 149 | sumcpiter= sumcpiter + erepmd ! CP iteration error for report 150 | 151 | CALL ECHROT(a,aug,rl,dp1,dph,dp2) ! Estimate of orientation change 152 | 153 | !-----------------------Calculate elasto-plastic modulus (invert) 154 | DO i=1,6 155 | erreps(1:6)=0. 156 | erreps(i) = 1. 157 | CALL SOLVER(6,djac,erreps) 158 | DO j=1,6 159 | chi(j,i)= erreps(j) 160 | END DO 161 | END DO 162 | 163 | ! Put current orientation change and slip resistance 164 | ! change terms into state variable list 165 | dsv(1,jgp)=dp1 166 | dsv(2,jgp)=dph 167 | dsv(3,jgp)=dp2 168 | DO i=1,nss(mat_code) 169 | dsv(i+3,jgp)=s1(i)-s0(i) 170 | END DO 171 | 172 | END SUBROUTINE CPSTRS 173 | 174 | !***********************************************************************! 175 | ! ! 176 | ! SUBROUTINE SCALE_IT( am, gamcap, scale) ! 177 | !-----------------------------------------------------------------------! 178 | ! Routine to scale slip stress and strains increments ! 179 | !-----------------------------------------------------------------------! 180 | ! Arguments: am REAL; Slip rate sensitivity ! 181 | ! gamcap REAL; Cap on magnitude of slips ! 182 | ! scale REAL; Scaling for slips ! 183 | ! ! 184 | !-----------------------------------------------------------------------! 185 | ! ! 186 | !***********************************************************************! 187 | SUBROUTINE SCALE_IT( am, s, gamcap, scale) 188 | 189 | USE FAS_COM ! FASOLT main variables declaration 190 | USE FAS_CPL ! Crystal plasticity variables 191 | 192 | IMPLICIT NONE 193 | REAL(4) amax, gamcap, scale 194 | INTEGER(4) i, ii, k 195 | REAL(4) gammax, smult, SPOWER 196 | REAL(4), DIMENSION(1:maxss):: am 197 | REAL(4), DIMENSION(1:6):: s 198 | 199 | !------------------get biggest slip increment and its rate sensitivity 200 | amax= am(1) 201 | gammax=ABS(gam(isa(1))) 202 | 203 | DO i= 2, nsa 204 | ii= isa(i) 205 | IF (ABS(gam(ii)) .GT. gammax) THEN 206 | gammax= ABS(gam(ii)) 207 | amax= am(ii) 208 | END IF 209 | END DO 210 | 211 | !------------------calculate approximate scaling for strain and stress 212 | IF (gammax .GT. gamcap) THEN 213 | scale= gamcap/gammax 214 | smult= SPOWER(0.9*scale, afactor*amax) 215 | 216 | ! This is a fiddle for small m values only and may never happen! 217 | IF (smult.EQ.0.) smult=0.004/amax 218 | 219 | DO i= 1, 6 220 | s(i)= smult*s(i) 221 | END DO 222 | DO i= 1, nss(mat_code) 223 | gam(i)= scale*gam(i) 224 | tau(i)= smult*tau(i) 225 | END DO 226 | ELSE 227 | scale=1. 228 | ENDIF 229 | 230 | END SUBROUTINE SCALE_IT 231 | -------------------------------------------------------------------------------- /src/fasolt/Elvals.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE ELVALS ! 4 | !-----------------------------------------------------------------------! 5 | ! Evaluation and assembly of elemental quantities for deformation of ! 6 | ! elasto-viscoplastic material for use with Newton-Raphson scheme ! 7 | ! ! 8 | !-----------------------------------------------------------------------! 9 | ! ! 10 | !***********************************************************************! 11 | SUBROUTINE ELVALS 12 | 13 | USE FAS_COM ! FASOLT main variables declaration 14 | 15 | IMPLICIT NONE 16 | 17 | INTEGER(4) in, in2, ip, i, j, ii, jj, k, l, iel, itp 18 | INTEGER(4) nn, ng, ks, ig, ilmnt 19 | REAL(4) sf, d, r, esm, gaussm, defl, weight, small 20 | 21 | REAL(4), DIMENSION (1:3, 1:20) :: xl, dxl, sfd, fl 22 | REAL(4), DIMENSION ( 1:6) :: stl, epl, dsl, del, s 23 | 24 | DIMENSION r( 1:3), sf( 1:20), in( 1:20), d(1:6, 1:6), in2(1:60), & 25 | & ip(1:8), esm( 1:60, 1:60), gaussm( 1:3, 1:3) 26 | 27 | 28 | 29 | DATA small/ 1.e-7/ ! check on element weighting ( volume) 30 | 31 | DO ilmnt=1,nlmnt ! Loop on elements 32 | 33 | !------------Get element type, nodes and local pointer 34 | 35 | iel= le(ilmnt) 36 | itp= lt(ilmnt) 37 | nn = nd(ilmnt) 38 | ng = np(ilmnt) 39 | in(1:nn)=ln( 1:nn, ilmnt) 40 | 41 | DO i= 1, nn 42 | DO j= -2, 0 43 | in2( 3*i + j) = 3*in(i) + j 44 | END DO 45 | END DO 46 | 47 | !----------Initialise relevant arrays 48 | 49 | fl(1:3,1:nn)=0. 50 | esm( 1:3*nn, 1:3*nn)= 0. 51 | 52 | !-------Get coordinates and displacements 53 | DO i= 1, nn 54 | ks= 3*in(i) - 3 55 | DO j= 1, 3 56 | xl(j,i) = x(ks+j) 57 | dxl(j,i)= dx(ks+j) 58 | END DO 59 | END DO 60 | 61 | 62 | IF ( itp .LT. 9) THEN ! 'Tie' ( 0 Gauss points) Element 63 | 64 | SELECT CASE ( itp) 65 | 66 | CASE(1,2,3) 67 | esm(itp,itp)= efix ; esm(itp,itp+3)= -efix 68 | 69 | CASE(4,5,6) 70 | ii= 1 + MOD(itp-3,3) 71 | esm(ii,ii)= efix ; esm(ii,ii+3)= -efix 72 | 73 | ii= 1 + MOD(ii,3) 74 | esm(ii,ii)= efix ; esm(ii,ii+3)= -efix 75 | 76 | 77 | END SELECT 78 | 79 | ELSE ! 'Real' Element (>0 Gauss points) 80 | 81 | ip(1:ng)=lg( 1:ng, ilmnt) ! set Gauss point numbers 82 | 83 | DO ig= 1, ng ! Numerically integrate over element 84 | 85 | 86 | !--------Choose shape function 87 | SELECT CASE( itp ) 88 | 89 | CASE(12) 90 | CALL SHAPE_12( ig, xl, sf, sfd, weight ) 91 | 92 | CASE(21) 93 | CALL SHAPE_21( ig, xl, sf, sfd, weight ) 94 | 95 | CASE(22) 96 | CALL SHAPE_22( ig, xl, sf, sfd, weight ) 97 | 98 | CASE(23) 99 | CALL SHAPE_23( ig, xl, sf, sfd, weight ) 100 | 101 | END SELECT 102 | 103 | IF ( weight .LT. small ) CALL FAFERR(920) 104 | 105 | !--Get values for total strain and stress at the Gauss point 106 | j = ip(ig) 107 | epl( 1:6)= ep( 1:6, j) 108 | stl( 1:6)= st( 1:6, j) 109 | dsl( 1:6)= ds( 1:6, j) 110 | 111 | !--------Get deformation updated strain & stress increments 112 | CALL DSTRNS(nn, sfd, dxl, del, r, defl) 113 | CALL DSTRSS(iel,j,defl,epl,del,stl,dsl,s,r,d) 114 | 115 | !------Renew global vectors of these, and rotation, quantities 116 | dep(j)= defl 117 | de(1:6,j)= del(1:6) 118 | ds(1:6,j)= dsl(1:6) 119 | dr(1:3,j)= r(1:3) 120 | 121 | !---------Calculate nodal force contribution and add in 122 | DO i= 1, nn 123 | fl(1, i)= fl(1, i) +weight*( s(1)*sfd(1,i) +s(6)*sfd(2,i) +s(5)*sfd(3,i) ) 124 | fl(2, i)= fl(2, i) +weight*( s(2)*sfd(2,i) +s(4)*sfd(3,i) +s(6)*sfd(1,i) ) 125 | fl(3, i)= fl(3, i) +weight*( s(3)*sfd(3,i) +s(5)*sfd(1,i) +s(4)*sfd(2,i) ) 126 | END DO 127 | 128 | !---------Calculate mechanical stiffness contribution and add in 129 | DO i= 1, nn 130 | DO j= 1, nn 131 | 132 | gaussm(1,1)= ( sfd(1,i)*sfd(1,j)*( d(1,1) - s(1) ) + & 133 | & sfd(2,i)*sfd(2,j)*( d(6,6) - (s(1)-s(2))/2.) + & 134 | & sfd(3,i)*sfd(3,j)*( d(5,5) - (s(1)-s(3))/2.) + & 135 | & sfd(2,i)*sfd(3,j)*(d(5,6) + s(4)/2. ) + & 136 | & sfd(3,i)*sfd(1,j)*(d(1,5) ) + & 137 | & sfd(1,i)*sfd(2,j)*(d(1,6) ) + & 138 | & sfd(2,j)*sfd(3,i)*(d(5,6) + s(4)/2. ) + & 139 | & sfd(3,j)*sfd(1,i)*(d(1,5) ) + & 140 | & sfd(1,j)*sfd(2,i)*(d(1,6) ) ) 141 | 142 | gaussm(2,1)= ( sfd(1,i)*sfd(1,j)*( d(1,6) - s(6) ) + & 143 | & sfd(2,i)*sfd(2,j)*( d(2,6) - s(6) ) + & 144 | & sfd(3,i)*sfd(3,j)*( d(4,5) - s(6)/2. ) + & 145 | & sfd(2,i)*sfd(3,j)*( d(2,5) - s(5)/4. ) + & 146 | & sfd(3,i)*sfd(1,j)*( d(1,4) - s(4)/4. ) + & 147 | & sfd(1,i)*sfd(2,j)*( d(6,6) - (s(1)+s(2))/4. ) + & 148 | & sfd(2,j)*sfd(3,i)*( d(4,6) - s(5)/4. ) + & 149 | & sfd(3,j)*sfd(1,i)*( d(5,6) - s(4)/4. ) + & 150 | & sfd(1,j)*sfd(2,i)*( d(1,2) - (s(1)+s(2))/4. ) ) 151 | 152 | gaussm(3,1)= ( sfd(1,i)*sfd(1,j)*( d(1,5) - s(5) ) + & 153 | & sfd(2,i)*sfd(2,j)*( d(4,6) - s(5)/2. ) + & 154 | & sfd(3,i)*sfd(3,j)*( d(3,5) - s(5) ) + & 155 | & sfd(2,i)*sfd(3,j)*( d(4,5) - s(6)/4. ) + & 156 | & sfd(3,i)*sfd(1,j)*( d(1,3) - (s(1)+s(3))/4. ) + & 157 | & sfd(1,i)*sfd(2,j)*( d(5,6) - s(4)/4. ) + & 158 | & sfd(2,j)*sfd(3,i)*( d(3,6) - s(6)/4. ) + & 159 | & sfd(3,j)*sfd(1,i)*( d(5,5) - (s(1)+s(3))/4. ) + & 160 | & sfd(1,j)*sfd(2,i)*( d(1,4) - s(4)/4. ) ) 161 | 162 | gaussm(1,2)= ( sfd(1,j)*sfd(1,i)*( d(1,6) - s(6) ) + & 163 | & sfd(2,j)*sfd(2,i)*( d(2,6) - s(6) ) + & 164 | & sfd(3,j)*sfd(3,i)*( d(4,5) - s(6)/2. ) + & 165 | & sfd(2,j)*sfd(3,i)*( d(2,5) - s(5)/4. ) + & 166 | & sfd(3,j)*sfd(1,i)*( d(1,4) - s(4)/4. ) + & 167 | & sfd(1,j)*sfd(2,i)*( d(6,6) - (s(1)+s(2))/4. ) + & 168 | & sfd(2,i)*sfd(3,j)*( d(4,6) - s(5)/4. ) + & 169 | & sfd(3,i)*sfd(1,j)*( d(5,6) - s(4)/4. ) + & 170 | & sfd(1,i)*sfd(2,j)*( d(1,2) - (s(1)+s(2))/4. ) ) 171 | 172 | gaussm(2,2)= ( sfd(1,i)*sfd(1,j)*( d(6,6) - (s(2)-s(1))/2. ) + & 173 | & sfd(2,i)*sfd(2,j)*( d(2,2) - s(2) ) + & 174 | & sfd(3,i)*sfd(3,j)*( d(4,4) - (s(2)-s(3))/2. ) + & 175 | & sfd(2,i)*sfd(3,j)*( d(2,4) ) + & 176 | & sfd(3,i)*sfd(1,j)*( d(4,6) + s(5)/2. ) + & 177 | & sfd(1,i)*sfd(2,j)*( d(2,6) ) + & 178 | & sfd(2,j)*sfd(3,i)*( d(2,4) ) + & 179 | & sfd(3,j)*sfd(1,i)*( d(4,6) + s(5)/2. ) + & 180 | & sfd(1,j)*sfd(2,i)*( d(2,6) ) ) 181 | 182 | gaussm(3,2)= ( sfd(1,i)*sfd(1,j)*( d(5,6) - s(4)/2. ) + & 183 | & sfd(2,i)*sfd(2,j)*( d(2,4) - s(4) ) + & 184 | & sfd(3,i)*sfd(3,j)*( d(3,4) - s(4) ) + & 185 | & sfd(2,i)*sfd(3,j)*( d(4,4) - (s(2)+s(3))/4. ) + & 186 | & sfd(3,i)*sfd(1,j)*( d(3,6) - s(6)/4. ) + & 187 | & sfd(1,i)*sfd(2,j)*( d(2,5) - s(5)/4. ) + & 188 | & sfd(2,j)*sfd(3,i)*( d(2,3) - (s(2)+s(3))/4. ) + & 189 | & sfd(3,j)*sfd(1,i)*( d(4,5) - s(6)/4. ) + & 190 | & sfd(1,j)*sfd(2,i)*( d(4,6) - s(5)/4. ) ) 191 | 192 | gaussm(1,3)= ( sfd(1,j)*sfd(1,i)*( d(1,5) - s(5) ) + & 193 | & sfd(2,j)*sfd(2,i)*( d(4,6) - s(5)/2. ) + & 194 | & sfd(3,j)*sfd(3,i)*( d(3,5) - s(5) ) + & 195 | & sfd(2,j)*sfd(3,i)*( d(4,5) - s(6)/4. ) + & 196 | & sfd(3,j)*sfd(1,i)*( d(1,3) - (s(1)+s(3))/4. ) + & 197 | & sfd(1,j)*sfd(2,i)*( d(5,6) - s(4)/4. ) + & 198 | & sfd(2,i)*sfd(3,j)*( d(3,6) - s(6)/4. ) + & 199 | & sfd(3,i)*sfd(1,j)*( d(5,5) - (s(1)+s(3))/4. ) + & 200 | & sfd(1,i)*sfd(2,j)*( d(1,4) - s(4)/4. ) ) 201 | 202 | gaussm(2,3)= ( sfd(1,j)*sfd(1,i)*( d(5,6) - s(4)/2. ) + & 203 | & sfd(2,j)*sfd(2,i)*( d(2,4) - s(4) ) + & 204 | & sfd(3,j)*sfd(3,i)*( d(3,4) - s(4) ) + & 205 | & sfd(2,j)*sfd(3,i)*( d(4,4) - (s(2)+s(3))/4. ) + & 206 | & sfd(3,j)*sfd(1,i)*( d(3,6) - s(6)/4. ) + & 207 | & sfd(1,j)*sfd(2,i)*( d(2,5) - s(5)/4. ) + & 208 | & sfd(2,i)*sfd(3,j)*( d(2,3) - (s(2)+s(3))/4. ) + & 209 | & sfd(3,i)*sfd(1,j)*( d(4,5) - s(6)/4. ) + & 210 | & sfd(1,i)*sfd(2,j)*( d(4,6) - s(5)/4. ) ) 211 | 212 | gaussm(3,3) =( sfd(1,i)*sfd(1,j)*( d(5,5) - (s(3)-s(1))/2.) + & 213 | & sfd(2,i)*sfd(2,j)*( d(4,4) - (s(3)-s(2))/2.) + & 214 | & sfd(3,i)*sfd(3,j)*( d(3,3) - s(3) ) + & 215 | & sfd(2,i)*sfd(3,j)*(d(3,4) ) + & 216 | & sfd(3,i)*sfd(1,j)*(d(3,5) ) + & 217 | & sfd(1,i)*sfd(2,j)*(d(4,5) + s(6)/2. ) + & 218 | & sfd(2,j)*sfd(3,i)*(d(3,4) ) + & 219 | & sfd(3,j)*sfd(1,i)*(d(3,5) ) + & 220 | & sfd(1,j)*sfd(2,i)*(d(4,5) + s(6)/2. ) ) 221 | 222 | 223 | gaussm= weight*gaussm 224 | 225 | esm( 3*i-2, 3*j-2)= esm( 3*i-2, 3*j-2) + gaussm(1,1) 226 | esm( 3*i-2, 3*j-1)= esm( 3*i-2, 3*j-1) + gaussm(1,2) 227 | esm( 3*i-2, 3*j )= esm( 3*i-2, 3*j ) + gaussm(1,3) 228 | esm( 3*i-1, 3*j-2)= esm( 3*i-1, 3*j-2) + gaussm(2,1) 229 | esm( 3*i-1, 3*j-1)= esm( 3*i-1, 3*j-1) + gaussm(2,2) 230 | esm( 3*i-1, 3*j )= esm( 3*i-1, 3*j ) + gaussm(2,3) 231 | esm( 3*i, 3*j-2)= esm( 3*i, 3*j-2) + gaussm(3,1) 232 | esm( 3*i, 3*j-1)= esm( 3*i, 3*j-1) + gaussm(3,2) 233 | esm( 3*i, 3*j )= esm( 3*i, 3*j ) + gaussm(3,3) 234 | 235 | END DO 236 | 237 | END DO 238 | 239 | END DO 240 | 241 | END IF 242 | 243 | !-----------------------Assemble mechanical stiffness into global array 244 | DO i= 1, 3*nn 245 | ii= in2(i) ! row 246 | 247 | DO j= 1, 3*nn 248 | jj= in2(j) ! column number 249 | 250 | IF ( jj .NE. ii ) THEN ! column location 251 | k=2 252 | DO WHILE( jj .NE. is(k, ii) ) 253 | k=k+1 254 | END DO 255 | ELSE 256 | k=1 257 | END IF 258 | 259 | ss(k,ii)= ss(k,ii) + esm(i,j) 260 | 261 | END DO 262 | END DO 263 | 264 | !-----------------------------Return nodal force imbalance values 265 | DO i= 1, nn 266 | k= 3*in(i) - 3 267 | DO j= 1, 3 268 | l= k + j 269 | fc(l)= fc(l) + fl(j,i) 270 | END DO 271 | END DO 272 | 273 | END DO 274 | 275 | END SUBROUTINE ELVALS 276 | -------------------------------------------------------------------------------- /src/fasolt/Faslt_io.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE RDDATA ! 4 | !-----------------------------------------------------------------------! 5 | ! Reads data file for FASOLT3 ! 6 | !-----------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************! 9 | SUBROUTINE RDDATA(f_name) 10 | 11 | USE FAS_COM ! FASOLT main variables declaration 12 | USE FAS_CPL ! FASOLT material property block 13 | 14 | IMPLICIT NONE 15 | 16 | CHARACTER*(*) f_name 17 | LOGICAL(4) l_file 18 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe 19 | 20 | INTEGER(4) iomon, in, out 21 | COMMON/ iochan/ iomon, in, out 22 | 23 | !-------------------------common dialog to open file and get file name 24 | CALL COMDIALR( in, l_file, f_name) 25 | IF ( .NOT. l_file) CALL FAFERR(501) 26 | 27 | !-----------------------------------------------------read FAFNER data 28 | 29 | READ(in) ninc ! start increment 30 | ninc0=ninc+1 31 | 32 | READ(in) nlmnt, nnod, ngps, nsv ! size of mesh 33 | IF( nlmnt.GT. maxels .OR. nnod.GT. maxnod .OR. & 34 | & ngps .GT. maxgps .OR. nsv .GT. maxsvs ) CALL FAFERR(510) 35 | 36 | !------------------------read element definitions 37 | DO i= 1, nlmnt 38 | READ(in) le(i), lt(i), nde, npe 39 | READ(in)(ln(j,i), j= 1, nde) 40 | READ(in)(lg(j,i), j= 1, npe) 41 | nd(i)=nde 42 | np(i)=npe 43 | END DO 44 | 45 | !----------------------read nodal variables 46 | DO i= 1, nnod 47 | i3= 3*i 48 | i2= i3 - 1 49 | i1= i2 - 1 50 | READ(in) ib(i) 51 | READ(in) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 52 | READ(in) fc(i1), fc(i2), fc(i3) 53 | END DO 54 | 55 | !---------------------read integration point variables 56 | DO i= 1, ngps 57 | READ(in) eps(i), dep(i) 58 | READ(in) ( sv(j,i), j= 1, nsv) 59 | READ(in) (dsv(j,i), j= 1, nsv) 60 | READ(in) (ep(j,i), j= 1, 6) 61 | READ(in) (de(j,i), j= 1, 6) 62 | READ(in) (st(j,i), j= 1, 6) 63 | READ(in) (ds(j,i), j= 1, 6) 64 | READ(in) (rt(j,i), j= 1, 3) 65 | READ(in) (dr(j,i), j= 1, 3) 66 | END DO 67 | 68 | !-----------------------------initialise material properies to zero 69 | e= 0. 70 | nss= 0 71 | ab= 0. ; an= 0. 72 | ampar= 0. 73 | smatrx= 0. 74 | 75 | !------------------------------------------read material properties 76 | READ(in) nmatl, nmpar 77 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 78 | DO mat_code= 1, nmatl 79 | READ(in) nss(mat_code) 80 | IF ( nss(mat_code) .GT. maxss ) CALL FAFERR(602) 81 | IF ( nss(mat_code) .GT. maxsvs -3 ) CALL FAFERR(603) 82 | 83 | !------------------------------------real elastic constants 84 | READ(in) (e(j, mat_code), j= 1, 9) 85 | 86 | !-----------------------------------------read slip systems 87 | DO i= 1, nss(mat_code) 88 | READ(in) (ab(j,i,mat_code),j=1,3), & 89 | & (an(j,i,mat_code),j=1,3) 90 | END DO 91 | !---------------------------------------read ss properties 92 | DO i= 1, nss(mat_code) 93 | READ(in) (ampar(j,i,mat_code),j=1,nmpar) 94 | END DO 95 | 96 | !--------------------------------read latent hardening matrix 97 | DO i=1,nss(mat_code) 98 | READ(in) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 99 | END DO 100 | 101 | END DO 102 | 103 | !---------------------------read surface properties 104 | READ(in) amu, anu, aga 105 | 106 | !---------------------------------read control data 107 | READ(in) ninc1, nxs, nfs 108 | DO i= 1, ninc1 109 | READ(in) tiem(i) 110 | IF ( nxs .GT. 0 ) THEN 111 | DO j= 1, nxs 112 | READ(in) ( x_spec(k,j,i), k= 1,15) 113 | END DO 114 | ENDIF 115 | IF ( nfs .GT. 0 ) THEN 116 | DO j= 1, nfs 117 | READ(in) ( f_spec(k,j,i), k= 1, 3) 118 | END DO 119 | ENDIF 120 | END DO 121 | 122 | CLOSE(in) 123 | 124 | !----------------------------------------open report file 125 | OPEN( UNIT=iomon, FILE='fafrep.txt') 126 | 127 | 128 | END SUBROUTINE RDDATA 129 | 130 | !***********************************************************************! 131 | ! ! 132 | ! SUBROUTINE WTDATA ! 133 | !-----------------------------------------------------------------------! 134 | ! Writes results file for FASOLT3 ! 135 | !-----------------------------------------------------------------------! 136 | ! ! 137 | !***********************************************************************! 138 | SUBROUTINE WTDATA(f_name) 139 | 140 | USE FAS_COM ! FASOLT main variables declaration 141 | USE FAS_CPL ! FASOLT material property block 142 | 143 | IMPLICIT NONE 144 | 145 | CHARACTER*(*) f_name 146 | LOGICAL(4) l_file 147 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe, ierr 148 | 149 | 150 | INTEGER(4) iomon, in, out 151 | COMMON/ iochan/ iomon, in, out 152 | 153 | !----------------------------------------------------------open file 154 | OPEN( UNIT= out, FILE= f_name, FORM= 'UNFORMATTED', & 155 | & ACCESS= 'SEQUENTIAL', STATUS= 'UNKNOWN', IOSTAT= ierr) 156 | IF ( ierr .NE. 0) CALL FAFERR(502) 157 | 158 | !-----------------------------------------------write FAFNER results 159 | WRITE(out) inc ! increment 160 | 161 | WRITE(out) nlmnt, nnod, ngps, nsv ! size of mesh etc. 162 | 163 | !------------------------write element definitions 164 | DO i= 1, nlmnt 165 | nde=nd(i) 166 | npe=np(i) 167 | WRITE(out) le(i), lt(i), nde, npe 168 | WRITE(out)(ln(j,i), j= 1, nde) 169 | WRITE(out)(lg(j,i), j= 1, npe) 170 | END DO 171 | 172 | !----------------------write nodal variables 173 | DO i= 1, nnod 174 | i3= 3*i 175 | i2= i3 - 1 176 | i1= i2 - 1 177 | WRITE(out) ib(i) 178 | WRITE(out) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 179 | WRITE(out) fc(i1), fc(i2), fc(i3) 180 | END DO 181 | 182 | !---------------------write integration point variables 183 | DO i= 1, ngps 184 | WRITE(out) eps(i), dep(i) 185 | WRITE(out) ( sv(j,i), j= 1, nsv) 186 | WRITE(out) (dsv(j,i), j= 1, nsv) 187 | WRITE(out) (ep(j,i), j= 1, 6) 188 | WRITE(out) (de(j,i), j= 1, 6) 189 | WRITE(out) (st(j,i), j= 1, 6) 190 | WRITE(out) (ds(j,i), j= 1, 6) 191 | WRITE(out) (rt(j,i), j= 1, 3) 192 | WRITE(out) (dr(j,i), j= 1, 3) 193 | END DO 194 | 195 | !------------------------------------------write material properties 196 | WRITE(out) nmatl, nmpar 197 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 198 | DO mat_code= 1, nmatl 199 | WRITE(out) nss(mat_code) 200 | 201 | !------------------------------------write elastic constants 202 | WRITE(out) (e(j, mat_code), j= 1, 9) 203 | 204 | !-----------------------------------------write slip systems 205 | DO i= 1, nss(mat_code) 206 | WRITE(out) (ab(j,i,mat_code),j=1,3), & 207 | & (an(j,i,mat_code),j=1,3) 208 | END DO 209 | !---------------------------------------write ss properties 210 | DO i= 1, nss(mat_code) 211 | WRITE(out) (ampar(j,i,mat_code),j=1,nmpar) 212 | END DO 213 | 214 | !--------------------------------write latent hardening matrix 215 | DO i=1,nss(mat_code) 216 | WRITE(out) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 217 | END DO 218 | 219 | END DO 220 | 221 | !---------------------------write surface properties 222 | WRITE(out) amu, anu, aga 223 | 224 | !---------------------------------write control data 225 | WRITE(out) ninc1, nxs, nfs 226 | DO i= 1, ninc1 227 | WRITE(out) tiem(i) 228 | IF ( nxs .GT. 0 ) THEN 229 | DO j= 1, nxs 230 | WRITE(out) ( x_spec(k,j,i), k= 1,15) 231 | END DO 232 | ENDIF 233 | IF ( nfs .GT. 0 ) THEN 234 | DO j= 1, nfs 235 | WRITE(out) ( f_spec(k,j,i), k= 1, 3) 236 | END DO 237 | ENDIF 238 | END DO 239 | 240 | CLOSE(out) 241 | 242 | END SUBROUTINE WTDATA 243 | 244 | !***********************************************************************! 245 | ! ! 246 | ! SUBROUTINE ITHEAD(ninc) ! 247 | !-----------------------------------------------------------------------! 248 | ! Writes iteration report header to monitor channel ! 249 | !-----------------------------------------------------------------------! 250 | ! ! 251 | !***********************************************************************! 252 | SUBROUTINE ITHEAD(inc) 253 | 254 | IMPLICIT NONE 255 | 256 | INTEGER(4) iomon, in, out, inc 257 | 258 | COMMON/ iochan/ iomon, in, out 259 | 260 | WRITE(iomon,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 261 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 262 | WRITE(* ,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 263 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 264 | 265 | END SUBROUTINE ITHEAD 266 | 267 | !***********************************************************************! 268 | ! ! 269 | ! SUBROUTINE ITEREP(nit,sdx,sfc,alp2) ! 270 | !-----------------------------------------------------------------------! 271 | ! Writes iteration status to monitor channel ! 272 | !-----------------------------------------------------------------------! 273 | ! ! 274 | !***********************************************************************! 275 | SUBROUTINE ITEREP(nit,sdx,sfc,cper,alp2) 276 | 277 | IMPLICIT NONE 278 | 279 | INTEGER(4) iomon, in, out, nit 280 | REAL(4) sdx, sfc, cper, alp2 281 | 282 | COMMON/ iochan/ iomon, in, out 283 | 284 | WRITE(iomon,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 285 | WRITE(* ,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 286 | 287 | END SUBROUTINE ITEREP 288 | 289 | !***********************************************************************! 290 | ! ! 291 | ! SUBROUTINE POWER ! 292 | !-----------------------------------------------------------------------! 293 | ! Reports the power f.dx/dt for the the whole domain ! 294 | ! ! 295 | !***********************************************************************! 296 | SUBROUTINE POWER 297 | 298 | USE FAS_COM 299 | 300 | IMPLICIT NONE 301 | INTEGER(4) iomon, in, out 302 | 303 | COMMON/ iochan/ iomon, in, out 304 | 305 | WRITE(iomon,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 306 | WRITE(* ,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 307 | 308 | 309 | END SUBROUTINE 310 | 311 | !***********************************************************************! 312 | ! ! 313 | ! SUBROUTINE COMDIALR ! 314 | !-----------------------------------------------------------------------! 315 | ! Routine to OPEN file via common dialog for READ ! 316 | ! ! 317 | !-----------------------------------------------------------------------! 318 | ! Arguments: IN INTEGER; READ channel number ! 319 | ! L_FILE LOGICAL; TRUE if file opened ok ! 320 | ! f_name CHARACTER; file name ! 321 | !-----------------------------------------------------------------------! 322 | ! ! 323 | !***********************************************************************! 324 | SUBROUTINE COMDIALR(in,l_file,f_name) 325 | 326 | USE DFLIB 327 | USE DFWIN 328 | 329 | IMPLICIT NONE 330 | 331 | TYPE (T_OPENFILENAME)FRED 332 | 333 | LOGICAL(KIND=4) RET, L_FILE 334 | INTEGER(KIND=4) IERROR, IN, IERR 335 | CHARACTER(LEN=26*7) ALLFILTERS 336 | CHARACTER(LEN=60) DLGTITLE 337 | CHARACTER*(*) f_name 338 | CHARACTER*100 drive, dirctry, dir, name, ext 339 | 340 | !-----------------------------------------------------get directory from local .inf file 341 | OPEN(in,FILE='fasdpth.inf',STATUS='OLD', IOSTAT=IERR) 342 | IF ( IERR .EQ. 0 ) THEN 343 | READ(in,*) DIRCTRY 344 | ELSE 345 | DIRCTRY=' ' 346 | END IF 347 | CLOSE(in) 348 | 349 | 350 | ALLFILTERS = 'Data files(*.fsd)' // char(0) //'*.fsd' // char(0) // & 351 | & 'All files(*.*)' // char(0) //'*.*' // char(0) // char(0) 352 | 353 | 354 | DLGTITLE = 'Input FASOLT Data File'//char(0) 355 | 356 | 357 | FRED%LSTRUCTSIZE = (BIT_SIZE(FRED%LSTRUCTSIZE) + & 358 | & BIT_SIZE(FRED%HWNDOWNER) + & 359 | & BIT_SIZE(FRED%HINSTANCE) + & 360 | & BIT_SIZE(FRED%LPSTRFILTER) + & 361 | & BIT_SIZE(FRED%LPSTRCUSTOMFILTER) + & 362 | & BIT_SIZE(FRED%NMAXCUSTFILTER) + & 363 | & BIT_SIZE(FRED%NFILTERINDEX) + & 364 | & BIT_SIZE(FRED%LPSTRFILE) + & 365 | & BIT_SIZE(FRED%NMAXFILE) + & 366 | & BIT_SIZE(FRED%LPSTRFILETITLE) + & 367 | & BIT_SIZE(FRED%NMAXFILETITLE) + & 368 | & BIT_SIZE(FRED%LPSTRINITIALDIR) + & 369 | & BIT_SIZE(FRED%LPSTRTITLE) + & 370 | & BIT_SIZE(FRED%FLAGS) + & 371 | & BIT_SIZE(FRED%NFILEOFFSET) + & 372 | & BIT_SIZE(FRED%NFILEEXTENSION) + & 373 | & BIT_SIZE(FRED%LPSTRDEFEXT) + & 374 | & BIT_SIZE(FRED%LCUSTDATA) + & 375 | & BIT_SIZE(FRED%LPFNHOOK) + & 376 | & BIT_SIZE(FRED%LPTEMPLATENAME))/8 377 | 378 | FRED%HWNDOWNER = NULL 379 | FRED%HINSTANCE = NULL 380 | FRED%LPSTRFILTER = LOC(ALLFILTERS) 381 | FRED%LPSTRCUSTOMFILTER = NULL 382 | FRED%NMAXCUSTFILTER = NULL 383 | FRED%NFILTERINDEX = 1 384 | FRED%LPSTRFILE = LOC(F_NAME) 385 | FRED%NMAXFILE = LEN(F_NAME) 386 | FRED%LPSTRFILETITLE = NULL 387 | FRED%NMAXFILETITLE = NULL 388 | FRED%LPSTRINITIALDIR = LOC(TRIM(ADJUSTL(DIRCTRY))//char(0)) ! FRED%LPSTRINITIALDIR = NULL 389 | FRED%LPSTRTITLE = LOC(DLGTITLE) 390 | FRED%FLAGS = NULL 391 | FRED%NFILEOFFSET = NULL 392 | FRED%NFILEEXTENSION = NULL 393 | FRED%LPSTRDEFEXT = NULL 394 | FRED%LCUSTDATA = NULL 395 | FRED%LPFNHOOK = NULL 396 | FRED%LPTEMPLATENAME = NULL 397 | 398 | RET = GETOPENFILENAME(FRED) 399 | 400 | CALL COMDLGER(IERROR) !error messages about common dialog 401 | 402 | L_FILE = .FALSE. 403 | !----------------------- check to see if the ok button has been pressed 404 | IF(RET .AND. (IERROR == 0))THEN 405 | L_FILE = .TRUE. 406 | 407 | OPEN( UNIT= IN, FILE= F_NAME, FORM= 'UNFORMATTED', & 408 | & ACCESS= 'SEQUENTIAL', STATUS= 'OLD', IOSTAT= IERR) 409 | 410 | IF (IERR.NE.0) L_FILE=.FALSE. 411 | 412 | !----------------------------prepare file name for subsequent use! 413 | ierr = SPLITPATHQQ (f_name, drive, dir, name, ext) 414 | f_name=TRIM(drive)//TRIM(dir)//TRIM(name) 415 | 416 | ENDIF 417 | 418 | 419 | 420 | END SUBROUTINE COMDIALR 421 | 422 | 423 | !***********************************************************************! 424 | ! ! 425 | ! SUBROUTINE COMDLGER ! 426 | ! Pete Bate DONCASTERS plc 1999 ! 427 | !-----------------------------------------------------------------------! 428 | ! Routine to report common dialog creation errors ! 429 | ! ! 430 | !-----------------------------------------------------------------------! 431 | ! Arguments: IRET INTEGER; Error code ! 432 | !-----------------------------------------------------------------------! 433 | ! ! 434 | !***********************************************************************! 435 | SUBROUTINE COMDLGER(IRET) 436 | 437 | USE DFLIB 438 | USE DFWIN 439 | 440 | IMPLICIT NONE 441 | 442 | CHARACTER(LEN=30)MSG1 443 | CHARACTER(LEN=210) MSG2 444 | INTEGER(KIND=4)IRET 445 | 446 | IRET = COMMDLGEXTENDEDERROR() 447 | MSG1 = 'FILE OPEN DIALOG FAILURE'C 448 | SELECT CASE(IRET) 449 | CASE (CDERR_FINDRESFAILURE) 450 | MSG2 = 'Failed to find a specified resource.'C 451 | CASE (CDERR_INITIALIZATION) 452 | MSG2 = 'Failed during initialization.'C 453 | CASE (CDERR_LOCKRESFAILURE) 454 | MSG2 = 'Failed to lock a specified resource.'C 455 | CASE (CDERR_LOADRESFAILURE) 456 | MSG2 = 'Failed to load a specified resource.'C 457 | CASE (CDERR_LOADSTRFAILURE) 458 | MSG2 = 'Failed to load a specified string.'C 459 | CASE (CDERR_MEMALLOCFAILURE) 460 | MSG2 = 'Unable to allocate memory for internal structures.'C 461 | CASE (CDERR_MEMLOCKFAILURE) 462 | MSG2 = 'Unable to lock the memory associated with a handle.'C 463 | CASE (CDERR_NOHINSTANCE) 464 | MSG2 = 'Failed to provide a corresponding instance handle.'C 465 | CASE (CDERR_NOHOOK) 466 | MSG2 = 'Failed to provide pointer to corresp. hook function'C 467 | CASE (CDERR_NOTEMPLATE) 468 | MSG2 = 'Failed to provide a corresponding template.'C 469 | CASE (CDERR_STRUCTSIZE) 470 | MSG2 = 'The lStructSize member invalid.'C 471 | CASE (FNERR_BUFFERTOOSMALL) 472 | MSG2 = 'The buffer for a filename is too small.'C 473 | CASE (FNERR_INVALIDFILENAME) 474 | MSG2 = 'A filename is invalid.'C 475 | CASE (FNERR_SUBCLASSFAILURE) 476 | MSG2 = 'Insufficient memory was available.'C 477 | CASE DEFAULT 478 | MSG2 = 'Unknown error number'C 479 | END SELECT 480 | 481 | IF(IRET /= 0)THEN 482 | IRET = MESSAGEBOXQQ(MSG2, MSG1,MB$ICONEXCLAMATION .OR. MB$OK) 483 | ENDIF 484 | 485 | END SUBROUTINE COMDLGER 486 | 487 | 488 | 489 | -------------------------------------------------------------------------------- /src/fasolt/Faslt_io_nowin.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE RDDATA ! 4 | !-----------------------------------------------------------------------! 5 | ! Reads data file for FASOLT3 ! 6 | !-----------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************! 9 | SUBROUTINE RDDATA(f_name) 10 | 11 | USE FAS_COM ! FASOLT main variables declaration 12 | USE FAS_CPL ! FASOLT material property block 13 | 14 | IMPLICIT NONE 15 | 16 | CHARACTER*(*) f_name 17 | LOGICAL(4) l_file 18 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe 19 | 20 | INTEGER(4) iomon, in, out, f_len 21 | COMMON/ iochan/ iomon, in, out 22 | in=52 23 | 24 | !-------------------------common dialog to open file and get file name 25 | CALL INPFILE( in, l_file, f_name) 26 | IF ( .NOT. l_file) CALL FAFERR(501) 27 | !-----------------------------------------------------read FAFNER data 28 | 29 | READ(in) ninc ! start increment 30 | ninc0=ninc+1 31 | READ(in) nlmnt, nnod, ngps, nsv ! size of mesh 32 | IF( nlmnt.GT. maxels .OR. nnod.GT. maxnod .OR. & 33 | & ngps .GT. maxgps .OR. nsv .GT. maxsvs ) CALL FAFERR(510) 34 | 35 | !------------------------read element definitions 36 | DO i= 1, nlmnt 37 | READ(in) le(i), lt(i), nde, npe 38 | READ(in)(ln(j,i), j= 1, nde) 39 | READ(in)(lg(j,i), j= 1, npe) 40 | nd(i)=nde 41 | np(i)=npe 42 | END DO 43 | 44 | !----------------------read nodal variables 45 | DO i= 1, nnod 46 | i3= 3*i 47 | i2= i3 - 1 48 | i1= i2 - 1 49 | READ(in) ib(i) 50 | READ(in) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 51 | READ(in) fc(i1), fc(i2), fc(i3) 52 | END DO 53 | 54 | !---------------------read integration point variables 55 | DO i= 1, ngps 56 | READ(in) eps(i), dep(i) 57 | READ(in) ( sv(j,i), j= 1, nsv) 58 | READ(in) (dsv(j,i), j= 1, nsv) 59 | READ(in) (ep(j,i), j= 1, 6) 60 | READ(in) (de(j,i), j= 1, 6) 61 | READ(in) (st(j,i), j= 1, 6) 62 | READ(in) (ds(j,i), j= 1, 6) 63 | READ(in) (rt(j,i), j= 1, 3) 64 | READ(in) (dr(j,i), j= 1, 3) 65 | END DO 66 | 67 | !-----------------------------initialise material properies to zero 68 | e= 0. 69 | nss= 0 70 | ab= 0. ; an= 0. 71 | ampar= 0. 72 | smatrx= 0. 73 | 74 | !------------------------------------------read material properties 75 | READ(in) nmatl, nmpar 76 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 77 | DO mat_code= 1, nmatl 78 | READ(in) nss(mat_code) 79 | IF ( nss(mat_code) .GT. maxss ) CALL FAFERR(602) 80 | IF ( nss(mat_code) .GT. maxsvs -3 ) CALL FAFERR(603) 81 | 82 | !------------------------------------read twinning limit 83 | READ(in) twinlim 84 | 85 | !------------------------------------read twinning probability 86 | READ(in) twinprob 87 | 88 | !------------------------------------read elastic constants 89 | READ(in) (e(j, mat_code), j= 1, 9) 90 | 91 | !------------------------------------read slip/twin system reorientation angles 92 | READ(in) (ssang(j, mat_code), j= 1, nss(mat_code)) 93 | 94 | !-----------------------------------------read slip systems 95 | DO i= 1, nss(mat_code) 96 | READ(in) (ab(j,i,mat_code),j=1,3), & 97 | & (an(j,i,mat_code),j=1,3) 98 | END DO 99 | !---------------------------------------read ss properties 100 | DO i= 1, nss(mat_code) 101 | READ(in) (ampar(j,i,mat_code),j=1,nmpar) 102 | END DO 103 | 104 | !--------------------------------read latent hardening matrix 105 | DO i=1,nss(mat_code) 106 | READ(in) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 107 | END DO 108 | 109 | END DO 110 | 111 | !---------------------------read surface properties 112 | READ(in) amu, anu, aga 113 | 114 | !---------------------------------read control data 115 | READ(in) ninc1, nxs, nfs 116 | DO i= 1, ninc1 117 | READ(in) tiem(i) 118 | IF ( nxs .GT. 0 ) THEN 119 | DO j= 1, nxs 120 | READ(in) ( x_spec(k,j,i), k= 1,15) 121 | END DO 122 | ENDIF 123 | IF ( nfs .GT. 0 ) THEN 124 | DO j= 1, nfs 125 | READ(in) ( f_spec(k,j,i), k= 1, 3) 126 | END DO 127 | ENDIF 128 | END DO 129 | 130 | CLOSE(in) 131 | 132 | !----------Initialise tflag, cumslip, twinsys and timestwinned variables: 133 | tflag = 0 134 | do i= 1, ngps 135 | do j= 1, nss(1) 136 | cumslip(j,i) = 0. 137 | twinsys(i) = 0 138 | end do 139 | timestwinned(i) = 0 140 | end do 141 | 142 | !----------------------------------------open report file 143 | OPEN( UNIT=iomon, FILE='fafrep.txt') 144 | 145 | 146 | END SUBROUTINE RDDATA 147 | 148 | !***********************************************************************! 149 | ! ! 150 | ! SUBROUTINE WriteSlips ! 151 | !-----------------------------------------------------------------------! 152 | ! Writes slip rates for all slip systems to .slp files ! 153 | !-----------------------------------------------------------------------! 154 | ! ! 155 | !***********************************************************************! 156 | SUBROUTINE WriteSlips(f_name) 157 | 158 | USE FAS_COM ! FASOLT main variables declaration 159 | USE FAS_CPL ! FASOLT material property block 160 | 161 | IMPLICIT NONE 162 | 163 | CHARACTER*(*) f_name 164 | INTEGER(4) i, j 165 | 166 | write(*,*) f_name 167 | open (unit=54,file=f_name,action="write",status="replace") 168 | 169 | do i=1, ngps 170 | write(54,'(9999ES15.5)') (cumslip(j,i),j=1,nss(1)), (srate(j,i),j=1,nss(1)) 171 | end do 172 | 173 | close (54) 174 | 175 | END SUBROUTINE WriteSlips 176 | 177 | !***********************************************************************! 178 | ! ! 179 | ! SUBROUTINE WTDATA ! 180 | !-----------------------------------------------------------------------! 181 | ! Writes results file for FASOLT3 ! 182 | !-----------------------------------------------------------------------! 183 | ! ! 184 | !***********************************************************************! 185 | SUBROUTINE WTDATA(f_name) 186 | 187 | USE FAS_COM ! FASOLT main variables declaration 188 | USE FAS_CPL ! FASOLT material property block 189 | 190 | IMPLICIT NONE 191 | 192 | CHARACTER*(*) f_name 193 | LOGICAL(4) l_file 194 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe, ierr 195 | 196 | 197 | INTEGER(4) iomon, in, out 198 | COMMON/ iochan/ iomon, in, out 199 | 200 | !----------------------------------------------------------open file 201 | OPEN( UNIT= out, FILE= f_name, FORM= 'UNFORMATTED', & 202 | & ACCESS= 'SEQUENTIAL', STATUS= 'UNKNOWN', IOSTAT= ierr) 203 | write(*,*) f_name 204 | IF ( ierr .NE. 0) CALL FAFERR(502) 205 | 206 | !-----------------------------------------------write FAFNER results 207 | WRITE(out) inc ! increment 208 | 209 | WRITE(out) nlmnt, nnod, ngps, nsv ! size of mesh etc. 210 | 211 | !------------------------write element definitions 212 | DO i= 1, nlmnt 213 | nde=nd(i) 214 | npe=np(i) 215 | WRITE(out) le(i), lt(i), nde, npe 216 | WRITE(out)(ln(j,i), j= 1, nde) 217 | WRITE(out)(lg(j,i), j= 1, npe) 218 | END DO 219 | 220 | !----------------------write nodal variables 221 | DO i= 1, nnod 222 | i3= 3*i 223 | i2= i3 - 1 224 | i1= i2 - 1 225 | WRITE(out) ib(i) 226 | WRITE(out) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 227 | WRITE(out) fc(i1), fc(i2), fc(i3) 228 | END DO 229 | 230 | !---------------------write integration point variables 231 | DO i= 1, ngps 232 | WRITE(out) eps(i), dep(i) 233 | WRITE(out) (sv(j,i), j= 1, nsv) 234 | WRITE(out) (dsv(j,i), j= 1, nsv) 235 | WRITE(out) (ep(j,i), j= 1, 6) 236 | WRITE(out) (de(j,i), j= 1, 6) 237 | WRITE(out) (st(j,i), j= 1, 6) 238 | WRITE(out) (ds(j,i), j= 1, 6) 239 | WRITE(out) (rt(j,i), j= 1, 3) 240 | WRITE(out) (dr(j,i), j= 1, 3) 241 | END DO 242 | 243 | !------------------------------------------write material properties 244 | WRITE(out) nmatl, nmpar 245 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 246 | DO mat_code= 1, nmatl 247 | WRITE(out) nss(mat_code) 248 | 249 | !------------------------------------write twinning limit 250 | WRITE(out) twinlim 251 | 252 | !------------------------------------write twinning probability 253 | WRITE(out) twinprob 254 | 255 | !------------------------------------write elastic constants 256 | WRITE(out) (e(j, mat_code), j= 1, 9) 257 | 258 | !------------------------------------write slip system reorientation angles 259 | WRITE(out) (ssang(j, mat_code), j= 1, nss(mat_code)) 260 | 261 | !-----------------------------------------write slip systems 262 | DO i= 1, nss(mat_code) 263 | WRITE(out) (ab(j,i,mat_code),j=1,3), & 264 | & (an(j,i,mat_code),j=1,3) 265 | END DO 266 | !---------------------------------------write ss properties 267 | DO i= 1, nss(mat_code) 268 | WRITE(out) (ampar(j,i,mat_code),j=1,nmpar) 269 | END DO 270 | 271 | !--------------------------------write latent hardening matrix 272 | DO i=1,nss(mat_code) 273 | WRITE(out) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 274 | END DO 275 | 276 | END DO 277 | 278 | !---------------------------write surface properties 279 | WRITE(out) amu, anu, aga 280 | 281 | !---------------------------------write control data 282 | WRITE(out) ninc1, nxs, nfs 283 | DO i= 1, ninc1 284 | WRITE(out) tiem(i) 285 | IF ( nxs .GT. 0 ) THEN 286 | DO j= 1, nxs 287 | WRITE(out) ( x_spec(k,j,i), k= 1,15) 288 | END DO 289 | ENDIF 290 | IF ( nfs .GT. 0 ) THEN 291 | DO j= 1, nfs 292 | WRITE(out) ( f_spec(k,j,i), k= 1, 3) 293 | END DO 294 | ENDIF 295 | END DO 296 | 297 | CLOSE(out) 298 | 299 | END SUBROUTINE WTDATA 300 | 301 | !***********************************************************************! 302 | ! ! 303 | ! SUBROUTINE ITHEAD(ninc) ! 304 | !-----------------------------------------------------------------------! 305 | ! Writes iteration report header to monitor channel ! 306 | !-----------------------------------------------------------------------! 307 | ! ! 308 | !***********************************************************************! 309 | SUBROUTINE ITHEAD(inc) 310 | 311 | IMPLICIT NONE 312 | 313 | INTEGER(4) iomon, in, out, inc 314 | 315 | COMMON/ iochan/ iomon, in, out 316 | 317 | WRITE(iomon,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 318 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 319 | WRITE(* ,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 320 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 321 | 322 | END SUBROUTINE ITHEAD 323 | 324 | !***********************************************************************! 325 | ! ! 326 | ! SUBROUTINE ITEREP(nit,sdx,sfc,alp2) ! 327 | !-----------------------------------------------------------------------! 328 | ! Writes iteration status to monitor channel ! 329 | !-----------------------------------------------------------------------! 330 | ! ! 331 | !***********************************************************************! 332 | SUBROUTINE ITEREP(nit,sdx,sfc,cper,alp2) 333 | 334 | IMPLICIT NONE 335 | 336 | INTEGER(4) iomon, in, out, nit 337 | REAL(4) sdx, sfc, cper, alp2 338 | 339 | COMMON/ iochan/ iomon, in, out 340 | 341 | WRITE(iomon,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 342 | WRITE(* ,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 343 | 344 | END SUBROUTINE ITEREP 345 | 346 | !***********************************************************************! 347 | ! ! 348 | ! SUBROUTINE POWER ! 349 | !-----------------------------------------------------------------------! 350 | ! Reports the power f.dx/dt for the the whole domain ! 351 | ! ! 352 | !***********************************************************************! 353 | SUBROUTINE POWER 354 | 355 | USE FAS_COM 356 | 357 | IMPLICIT NONE 358 | INTEGER(4) iomon, in, out 359 | 360 | COMMON/ iochan/ iomon, in, out 361 | 362 | WRITE(iomon,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 363 | WRITE(* ,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 364 | 365 | 366 | END SUBROUTINE 367 | 368 | !***********************************************************************! 369 | ! ! 370 | ! SUBROUTINE INPFILE ! 371 | !-----------------------------------------------------------------------! 372 | ! Routine to OPEN FASOLT3 input file ! 373 | ! ! 374 | !-----------------------------------------------------------------------! 375 | !Arguments:IN INTEGER; READ channel number ! 376 | !L_FILE LOGICAL; TRUE if file opened ok ! 377 | !-----------------------------------------------------------------------! 378 | ! ! 379 | !***********************************************************************! 380 | 381 | 382 | 383 | SUBROUTINE INPFILE(in,l_file,f_name) 384 | IMPLICIT none 385 | LOGICAL(4) :: l_file 386 | INTEGER :: in,ierr 387 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3,f_name_old 388 | CHARACTER(4) :: ext 389 | 390 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 391 | IF ( ierr .EQ. 0 ) THEN 392 | READ(in,*) dir1,dir2,dir3 393 | dir=dir3 394 | ELSE 395 | WRITE(*,'("No dirname file found. Path is current directory.")') 396 | dir='' 397 | END IF 398 | CLOSE(in) 399 | 400 | 401 | WRITE(*,'(''Name of FASOLT input file (no extension): '',\)') 402 | ext=".fsd" 403 | CALL check_file(f_name,ext,dir) 404 | OPEN(in ,FILE=TRIM(dir)//TRIM(f_name)//TRIM(ext) ,STATUS='OLD', FORM= 'UNFORMATTED', & 405 | & ACCESS= 'SEQUENTIAL', IOSTAT=ierr) 406 | IF ( ierr .EQ. 0 ) THEN 407 | l_file = .TRUE. 408 | ELSE 409 | WRITE(*,'("Could not open input file! ")') 410 | l_file = .FALSE. 411 | END IF 412 | END SUBROUTINE INPFILE 413 | 414 | 415 | 416 | !***********************************************************************! 417 | ! ! 418 | ! SUBROUTINE check_file ! 419 | !-----------------------------------------------------------------------! 420 | ! Routine to help with inputing file to open ! 421 | ! ! 422 | !-----------------------------------------------------------------------! 423 | !Arguments:f_name ext dir; to define file and path ! 424 | !here LOGICAL; TRUE if file exhists ! 425 | !-----------------------------------------------------------------------! 426 | ! ! 427 | !***********************************************************************! 428 | 429 | SUBROUTINE check_file(f_name,ext,dir) 430 | IMPLICIT none 431 | CHARACTER(100), INTENT(OUT) :: f_name 432 | CHARACTER(100), INTENT(IN) :: dir 433 | CHARACTER(4), INTENT(IN) :: ext 434 | CHARACTER(100) f_name_old 435 | INTEGER :: i 436 | LOGICAL :: here 437 | 438 | DO i=1,3 439 | READ(*,*) f_name 440 | f_name_old=f_name 441 | f_name=TRIM(dir)//TRIM(f_name)//TRIM(ext) 442 | write(*,*) f_name 443 | INQUIRE(FILE=f_name, EXIST=here) 444 | 445 | IF (here) THEN 446 | EXIT 447 | ELSE IF (i .LT. 3) THEN 448 | WRITE (*,'("File not found. Try again.")') 449 | CYCLE 450 | ELSE 451 | WRITE (*,'("File not found. Exiting.")') 452 | STOP 453 | END IF 454 | END DO 455 | f_name=f_name_old 456 | END SUBROUTINE check_file 457 | 458 | 459 | 460 | 461 | -------------------------------------------------------------------------------- /src/fasolt/Faslt_io_nowin_gam.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE RDDATA ! 4 | !-----------------------------------------------------------------------! 5 | ! Reads data file for FASOLT3 ! 6 | !-----------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************! 9 | SUBROUTINE RDDATA(f_name) 10 | 11 | USE FAS_COM ! FASOLT main variables declaration 12 | USE FAS_CPL ! FASOLT material property block 13 | 14 | IMPLICIT NONE 15 | 16 | CHARACTER*(*) f_name 17 | LOGICAL(4) l_file 18 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe 19 | 20 | INTEGER(4) iomon, in, out, f_len 21 | COMMON/ iochan/ iomon, in, out 22 | in=52 23 | 24 | !-------------------------common dialog to open file and get file name 25 | CALL INPFILE( in, l_file, f_name) 26 | IF ( .NOT. l_file) CALL FAFERR(501) 27 | !-----------------------------------------------------read FAFNER data 28 | 29 | READ(in) ninc ! start increment 30 | ninc0=ninc+1 31 | READ(in) nlmnt, nnod, ngps, nsv ! size of mesh 32 | IF( nlmnt.GT. maxels .OR. nnod.GT. maxnod .OR. & 33 | & ngps .GT. maxgps .OR. nsv .GT. maxsvs ) CALL FAFERR(510) 34 | 35 | !------------------------read element definitions 36 | DO i= 1, nlmnt 37 | READ(in) le(i), lt(i), nde, npe 38 | READ(in)(ln(j,i), j= 1, nde) 39 | READ(in)(lg(j,i), j= 1, npe) 40 | nd(i)=nde 41 | np(i)=npe 42 | END DO 43 | 44 | !----------------------read nodal variables 45 | DO i= 1, nnod 46 | i3= 3*i 47 | i2= i3 - 1 48 | i1= i2 - 1 49 | READ(in) ib(i) 50 | READ(in) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 51 | READ(in) fc(i1), fc(i2), fc(i3) 52 | END DO 53 | 54 | !---------------------read integration point variables 55 | DO i= 1, ngps 56 | READ(in) eps(i), dep(i) 57 | READ(in) ( sv(j,i), j= 1, nsv) 58 | READ(in) (dsv(j,i), j= 1, nsv) 59 | READ(in) (ep(j,i), j= 1, 6) 60 | READ(in) (de(j,i), j= 1, 6) 61 | READ(in) (st(j,i), j= 1, 6) 62 | READ(in) (ds(j,i), j= 1, 6) 63 | READ(in) (rt(j,i), j= 1, 3) 64 | READ(in) (dr(j,i), j= 1, 3) 65 | END DO 66 | 67 | !-----------------------------initialise material properies to zero 68 | e= 0. 69 | nss= 0 70 | ab= 0. ; an= 0. 71 | ampar= 0. 72 | smatrx= 0. 73 | 74 | !------------------------------------------read material properties 75 | READ(in) nmatl, nmpar 76 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 77 | DO mat_code= 1, nmatl 78 | READ(in) nss(mat_code) 79 | IF ( nss(mat_code) .GT. maxss ) CALL FAFERR(602) 80 | IF ( nss(mat_code) .GT. maxsvs -3 ) CALL FAFERR(603) 81 | 82 | !------------------------------------real elastic constants 83 | READ(in) (e(j, mat_code), j= 1, 9) 84 | 85 | !-----------------------------------------read slip systems 86 | DO i= 1, nss(mat_code) 87 | READ(in) (ab(j,i,mat_code),j=1,3), & 88 | & (an(j,i,mat_code),j=1,3) 89 | END DO 90 | !---------------------------------------read ss properties 91 | DO i= 1, nss(mat_code) 92 | READ(in) (ampar(j,i,mat_code),j=1,nmpar) 93 | END DO 94 | 95 | !--------------------------------read latent hardening matrix 96 | DO i=1,nss(mat_code) 97 | READ(in) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 98 | END DO 99 | 100 | END DO 101 | 102 | !---------------------------read surface properties 103 | READ(in) amu, anu, aga 104 | 105 | !---------------------------------read control data 106 | READ(in) ninc1, nxs, nfs 107 | DO i= 1, ninc1 108 | READ(in) tiem(i) 109 | IF ( nxs .GT. 0 ) THEN 110 | DO j= 1, nxs 111 | READ(in) ( x_spec(k,j,i), k= 1,15) 112 | END DO 113 | ENDIF 114 | IF ( nfs .GT. 0 ) THEN 115 | DO j= 1, nfs 116 | READ(in) ( f_spec(k,j,i), k= 1, 3) 117 | END DO 118 | ENDIF 119 | END DO 120 | 121 | CLOSE(in) 122 | 123 | !----------------------------------------open report file 124 | OPEN( UNIT=iomon, FILE='fafrep.txt') 125 | 126 | 127 | END SUBROUTINE RDDATA 128 | 129 | !***********************************************************************! 130 | ! ! 131 | ! SUBROUTINE WTDATA ! 132 | !-----------------------------------------------------------------------! 133 | ! Writes results file for FASOLT3 ! 134 | !-----------------------------------------------------------------------! 135 | ! ! 136 | !***********************************************************************! 137 | SUBROUTINE WTDATA(f_name) 138 | 139 | USE FAS_COM ! FASOLT main variables declaration 140 | USE FAS_CPL ! FASOLT material property block 141 | 142 | IMPLICIT NONE 143 | 144 | CHARACTER*(*) f_name 145 | LOGICAL(4) l_file 146 | INTEGER(4) i, j, k, i1, i2, i3, nde, npe, ierr 147 | 148 | 149 | INTEGER(4) iomon, in, out 150 | COMMON/ iochan/ iomon, in, out 151 | 152 | !----------------------------------------------------------open file 153 | OPEN( UNIT= out, FILE= f_name, FORM= 'UNFORMATTED', & 154 | & ACCESS= 'SEQUENTIAL', STATUS= 'UNKNOWN', IOSTAT= ierr) 155 | write(*,*) f_name 156 | IF ( ierr .NE. 0) CALL FAFERR(502) 157 | 158 | !-----------------------------------------------write FAFNER results 159 | WRITE(out) inc ! increment 160 | 161 | WRITE(out) nlmnt, nnod, ngps, nsv ! size of mesh etc. 162 | 163 | !------------------------write element definitions 164 | DO i= 1, nlmnt 165 | nde=nd(i) 166 | npe=np(i) 167 | WRITE(out) le(i), lt(i), nde, npe 168 | WRITE(out)(ln(j,i), j= 1, nde) 169 | WRITE(out)(lg(j,i), j= 1, npe) 170 | END DO 171 | 172 | !----------------------write nodal variables 173 | DO i= 1, nnod 174 | i3= 3*i 175 | i2= i3 - 1 176 | i1= i2 - 1 177 | WRITE(out) ib(i) 178 | WRITE(out) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 179 | WRITE(out) fc(i1), fc(i2), fc(i3) 180 | END DO 181 | 182 | !---------------------write integration point variables 183 | DO i= 1, ngps 184 | WRITE(out) eps(i), dep(i) 185 | WRITE(out) (sv(j,i), j= 1, nsv) 186 | WRITE(out) (dsv(j,i), j= 1, nsv) 187 | WRITE(out) (ep(j,i), j= 1, 6) 188 | WRITE(out) (de(j,i), j= 1, 6) 189 | WRITE(out) (st(j,i), j= 1, 6) 190 | WRITE(out) (ds(j,i), j= 1, 6) 191 | WRITE(out) (rt(j,i), j= 1, 3) 192 | WRITE(out) (dr(j,i), j= 1, 3) 193 | END DO 194 | 195 | !------------------------------------------write material properties 196 | WRITE(out) nmatl, nmpar 197 | IF ( nmatl .GT. maxmds) CALL FAFERR(601) 198 | DO mat_code= 1, nmatl 199 | WRITE(out) nss(mat_code) 200 | 201 | !------------------------------------write elastic constants 202 | WRITE(out) (e(j, mat_code), j= 1, 9) 203 | 204 | !-----------------------------------------write slip systems 205 | DO i= 1, nss(mat_code) 206 | WRITE(out) (ab(j,i,mat_code),j=1,3), & 207 | & (an(j,i,mat_code),j=1,3) 208 | END DO 209 | !---------------------------------------write ss properties 210 | DO i= 1, nss(mat_code) 211 | WRITE(out) (ampar(j,i,mat_code),j=1,nmpar) 212 | END DO 213 | 214 | !--------------------------------write latent hardening matrix 215 | DO i=1,nss(mat_code) 216 | WRITE(out) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 217 | END DO 218 | 219 | END DO 220 | 221 | !---------------------------write surface properties 222 | WRITE(out) amu, anu, aga 223 | 224 | !---------------------------------write control data 225 | WRITE(out) ninc1, nxs, nfs 226 | DO i= 1, ninc1 227 | WRITE(out) tiem(i) 228 | IF ( nxs .GT. 0 ) THEN 229 | DO j= 1, nxs 230 | WRITE(out) ( x_spec(k,j,i), k= 1,15) 231 | END DO 232 | ENDIF 233 | IF ( nfs .GT. 0 ) THEN 234 | DO j= 1, nfs 235 | WRITE(out) ( f_spec(k,j,i), k= 1, 3) 236 | END DO 237 | ENDIF 238 | END DO 239 | !--------------------------write slip system activity 240 | WRITE(out) nss(mat_code) 241 | 242 | DO i=1,nss(mat_code) 243 | WRITE(out) gam(i) 244 | END DO 245 | 246 | 247 | 248 | CLOSE(out) 249 | 250 | END SUBROUTINE WTDATA 251 | 252 | !***********************************************************************! 253 | ! ! 254 | ! SUBROUTINE ITHEAD(ninc) ! 255 | !-----------------------------------------------------------------------! 256 | ! Writes iteration report header to monitor channel ! 257 | !-----------------------------------------------------------------------! 258 | ! ! 259 | !***********************************************************************! 260 | SUBROUTINE ITHEAD(inc) 261 | 262 | IMPLICIT NONE 263 | 264 | INTEGER(4) iomon, in, out, inc 265 | 266 | COMMON/ iochan/ iomon, in, out 267 | 268 | WRITE(iomon,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 269 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 270 | WRITE(* ,'(//,25X,''Increment number'',I4,/,10X,''Iteration'',2X,''Error(X)'', & 271 | & 2X,''Error(F)'',2X,''Err(CPI)'',2X,''Decelrn.'',/)') inc 272 | 273 | END SUBROUTINE ITHEAD 274 | 275 | !***********************************************************************! 276 | ! ! 277 | ! SUBROUTINE ITEREP(nit,sdx,sfc,alp2) ! 278 | !-----------------------------------------------------------------------! 279 | ! Writes iteration status to monitor channel ! 280 | !-----------------------------------------------------------------------! 281 | ! ! 282 | !***********************************************************************! 283 | SUBROUTINE ITEREP(nit,sdx,sfc,cper,alp2) 284 | 285 | IMPLICIT NONE 286 | 287 | INTEGER(4) iomon, in, out, nit 288 | REAL(4) sdx, sfc, cper, alp2 289 | 290 | COMMON/ iochan/ iomon, in, out 291 | 292 | WRITE(iomon,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 293 | WRITE(* ,'(12X,I3,4X,5(1X,E9.2))') nit, sdx, sfc, cper, alp2 294 | 295 | END SUBROUTINE ITEREP 296 | 297 | !***********************************************************************! 298 | ! ! 299 | ! SUBROUTINE POWER ! 300 | !-----------------------------------------------------------------------! 301 | ! Reports the power f.dx/dt for the the whole domain ! 302 | ! ! 303 | !***********************************************************************! 304 | SUBROUTINE POWER 305 | 306 | USE FAS_COM 307 | 308 | IMPLICIT NONE 309 | INTEGER(4) iomon, in, out 310 | 311 | COMMON/ iochan/ iomon, in, out 312 | 313 | WRITE(iomon,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 314 | WRITE(* ,'(/,5X,''Power: '',G12.5)') DOT_PRODUCT( fc(1:3*nnod),dx(1:3*nnod))/tiem(ninc1) 315 | 316 | 317 | END SUBROUTINE 318 | 319 | !***********************************************************************! 320 | ! ! 321 | ! SUBROUTINE INPFILE ! 322 | !-----------------------------------------------------------------------! 323 | ! Routine to OPEN FASOLT3 input file ! 324 | ! ! 325 | !-----------------------------------------------------------------------! 326 | !Arguments:IN INTEGER; READ channel number ! 327 | !L_FILE LOGICAL; TRUE if file opened ok ! 328 | !-----------------------------------------------------------------------! 329 | ! ! 330 | !***********************************************************************! 331 | 332 | 333 | 334 | SUBROUTINE INPFILE(in,l_file,f_name) 335 | IMPLICIT none 336 | LOGICAL(4) :: l_file 337 | INTEGER :: in,ierr 338 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3,f_name_old 339 | CHARACTER(4) :: ext 340 | 341 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 342 | IF ( ierr .EQ. 0 ) THEN 343 | READ(in,*) dir1,dir2,dir3 344 | dir=dir3 345 | ELSE 346 | WRITE(*,'("No dirname file found. Path is current directory.")') 347 | dir='' 348 | END IF 349 | CLOSE(in) 350 | 351 | 352 | WRITE(*,'(''Name of FASOLT input file (no extension): '',\)') 353 | ext=".fsd" 354 | CALL check_file(f_name,ext,dir) 355 | OPEN(in ,FILE=TRIM(dir)//TRIM(f_name)//TRIM(ext) ,STATUS='OLD', FORM= 'UNFORMATTED', & 356 | & ACCESS= 'SEQUENTIAL', IOSTAT=ierr) 357 | IF ( ierr .EQ. 0 ) THEN 358 | l_file = .TRUE. 359 | ELSE 360 | WRITE(*,'("Could not open input file! ")') 361 | l_file = .FALSE. 362 | END IF 363 | END SUBROUTINE INPFILE 364 | 365 | 366 | 367 | !***********************************************************************! 368 | ! ! 369 | ! SUBROUTINE check_file ! 370 | !-----------------------------------------------------------------------! 371 | ! Routine to help with inputing file to open ! 372 | ! ! 373 | !-----------------------------------------------------------------------! 374 | !Arguments:f_name ext dir; to define file and path ! 375 | !here LOGICAL; TRUE if file exhists ! 376 | !-----------------------------------------------------------------------! 377 | ! ! 378 | !***********************************************************************! 379 | 380 | SUBROUTINE check_file(f_name,ext,dir) 381 | IMPLICIT none 382 | CHARACTER(100), INTENT(OUT) :: f_name 383 | CHARACTER(100), INTENT(IN) :: dir 384 | CHARACTER(4), INTENT(IN) :: ext 385 | CHARACTER(100) f_name_old 386 | INTEGER :: i 387 | LOGICAL :: here 388 | 389 | DO i=1,3 390 | READ(*,*) f_name 391 | f_name_old=f_name 392 | f_name=TRIM(dir)//TRIM(f_name)//TRIM(ext) 393 | write(*,*) f_name 394 | INQUIRE(FILE=f_name, EXIST=here) 395 | 396 | IF (here) THEN 397 | EXIT 398 | ELSE IF (i .LT. 3) THEN 399 | WRITE (*,'("File not found. Try again.")') 400 | CYCLE 401 | ELSE 402 | WRITE (*,'("File not found. Exiting.")') 403 | STOP 404 | END IF 405 | END DO 406 | f_name=f_name_old 407 | END SUBROUTINE check_file 408 | 409 | 410 | 411 | 412 | -------------------------------------------------------------------------------- /src/fasolt/Fasolt3.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! FASOLT 3 ! 4 | ! Pete Bate ! 5 | !-----------------------------------------------------------------------! 6 | ! Three dimensional CPFEM ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | 11 | PROGRAM FASOLT 12 | 13 | USE FAS_COM ! FASOLT main variables declaration 14 | 15 | IMPLICIT NONE 16 | CHARACTER( LEN=4) text 17 | CHARACTER( LEN=100) f_name 18 | INTEGER(4) nsave, icurr, isave 19 | DIMENSION isave(1:100) 20 | 21 | !----------------------------------------------initialise and read data 22 | CALL FSINIT 23 | CALL RDDATA(f_name) 24 | CALL SETPTA 25 | 26 | !----------------------------------------------get the output increments 27 | write(*,'(15X,''Number of increments is: '',I4)') ninc 28 | WRITE(*,'(/,10X,''Enter number of intermediate saves (max. 99): '',\)') 29 | READ*,nsave 30 | IF( nsave .GT. 0) THEN 31 | WRITE(*,'(10X,''Enter intermediate increments to save at: '',\)') 32 | READ(*,*) ( isave(icurr),icurr=1,nsave) 33 | END IF 34 | 35 | ! open file to write twinning info: 36 | open (unit=55,file="twins",action="write",status="replace") 37 | !------------------------------------------perform incremental solutions 38 | DO inc= 1, ninc 39 | CALL UPDATE_NODE ! update node etc. values 40 | CALL NRITER ! iterate for solution 41 | CALL UPDATE_GPTV ! update Gauss point values 42 | 43 | IF (tflag .ne. 0) THEN ! Check if there's any twinning. 44 | CALL DoReorient ! Do twin reorientation. 45 | tflag = 0 ! reset overall twin flag to zero 46 | END IF 47 | 48 | !-------------------------------! save if required 49 | IF ( nsave .GT. 0 ) THEN 50 | DO icurr= 1, nsave 51 | IF ( inc .GE. isave(icurr) ) THEN 52 | WRITE( text, '(I4)') inc 53 | CALL WTDATA( TRIM(f_name)//'-'//TRIM(ADJUSTL(text))//'.frs') 54 | call WriteSlips( TRIM(f_name)//'-'//TRIM(ADJUSTL(text))//'.slp') 55 | isave(icurr)= ninc+1 56 | ENDIF 57 | END DO 58 | END IF 59 | 60 | END DO 61 | 62 | !----------------------------------------write final result data 63 | close (55) 64 | WRITE( text, '(I4)') ninc 65 | CALL WTDATA( TRIM(f_name)//'-'//TRIM(ADJUSTL(text))//'.frs') 66 | call WriteSlips( TRIM(f_name)//'-'//TRIM(ADJUSTL(text))//'.slp') 67 | 68 | END 69 | 70 | 71 | !***********************************************************************! 72 | ! ! 73 | ! SUBROUTINE DoReorient ! 74 | !-----------------------------------------------------------------------! 75 | ! Reorient twinned IPs according to angles specified in fmt file ! 76 | !-----------------------------------------------------------------------! 77 | ! ! 78 | !***********************************************************************! 79 | SUBROUTINE DoReorient 80 | 81 | USE FAS_COM ! FASOLT main variables declaration 82 | USE FAS_CPL ! FASOLT material property block 83 | 84 | IMPLICIT NONE 85 | 86 | INTEGER(4) i, j 87 | REAL(4) e1, e2, e3, e1n, e2n, e3n, c1, c2, c3, ss1, s2, s3, ang, c, s, u1, u2, u3 88 | ! ss1 to avoid conflict with module 89 | 90 | REAL(4), DIMENSION(1:3):: nvec, dvec 91 | REAL(4), DIMENSION(1:3, 1:3):: RM, ERM, FRM 92 | 93 | 94 | do j = 1, ngps ! loop over IPs 95 | if (twinsys(j) .ne. 0) then ! reorient this IP! 96 | ! get index of active twinning system: 97 | i = twinsys(j) 98 | 99 | ! get current Euler angles and twin reorientation angle: 100 | e1 = sv(1,j) 101 | e2 = sv(2,j) 102 | e3 = sv(3,j) 103 | ang = ssang(i,1) * 3.14159 / 180. ! convert to radians 104 | 105 | ! calculate rotation matrix of IP from current Euler angles: 106 | c1 = COS(e1) 107 | c2 = COS(e2) 108 | c3 = COS(e3) 109 | ss1 = SIN(e1) 110 | s2 = SIN(e2) 111 | s3 = SIN(e3) 112 | 113 | RM(1,1) = c1*c3 - c2*ss1*s3 114 | RM(1,2) = -c1*s3 - c2*c3*ss1 115 | RM(1,3) = ss1*s2 116 | RM(2,1) = c3*ss1 + c1*c2*s3 117 | RM(2,2) = c1*c2*c3 - ss1*s3 118 | RM(2,3) = -c1*s2 119 | RM(3,1) = s2*s3 120 | RM(3,2) = c3*s2 121 | RM(3,3) = c2 122 | 123 | ! calculate current normal vector and direction vector: 124 | nvec = MATMUL(RM, an(1:3,i,1)) 125 | dvec = MATMUL(RM, ab(1:3,i,1)) 126 | 127 | ! calculate rotation axis for twin reorientation: 128 | u1 = nvec(2) * dvec(3) - nvec(3) * dvec(2) 129 | u2 = nvec(3) * dvec(1) - nvec(1) * dvec(3) 130 | u3 = nvec(1) * dvec(2) - nvec(2) * dvec(1) 131 | 132 | ! calculate extra rotation matrix for twin reorientation: 133 | c = COS(ang) 134 | s = SIN(ang) 135 | 136 | ERM(1,1) = c + u1*u1 * (1. - c) 137 | ERM(1,2) = u1 * u2 * (1. - c) - u3 * s 138 | ERM(1,3) = u1 * u3 * (1. - c) + u2 * s 139 | ERM(2,1) = u1 * u2 * (1. - c) + u3 * s 140 | ERM(2,2) = c + u2*u2 * (1. - c) 141 | ERM(2,3) = u2 * u3 * (1. - c) - u1 * s 142 | ERM(3,1) = u1 * u3 * (1. - c) - u2 * s 143 | ERM(3,2) = u2 * u3 * (1. - c) + u1 * s 144 | ERM(3,3) = c + u3*u3 * (1. - c) 145 | 146 | ! multiply matrices to get updated rotation matrix for IP: 147 | FRM = MATMUL(ERM, RM) 148 | 149 | ! calculate new Euler angles from updated rotation matrix: 150 | e1n = ATAN2( FRM(1,3) , -FRM(2,3) ) 151 | ! check bounds for FRM(3,3) - if out of bounds, normalize: 152 | if (abs(FRM(3,3)) .gt. 1.) FRM(3,3) = FRM(3,3) / abs(FRM(3,3)) 153 | e2n = ACOS( FRM(3,3) ) 154 | e3n = ATAN2( FRM(3,1) , FRM(3,2) ) 155 | 156 | ! update sv variable using new Euler angle values: 157 | sv(1,j) = e1n 158 | sv(2,j) = e2n 159 | sv(3,j) = e3n 160 | ! IP reorientation done! 161 | 162 | ! write twinning information to file: 163 | ! (incr. number, IP index, system index, Eulers before, Eulers after) 164 | write(55,'(I8, I8, I8, 9999ES15.5)') inc, j, i, e1, e2, e3, e1n, e2n, e3n 165 | 166 | twinsys(j) = 0 ! reset twinning system to 0! 167 | ! increment number of times this IP has twinned: 168 | timestwinned(j) = timestwinned(j) + 1 169 | end if 170 | 171 | end do 172 | 173 | 174 | 175 | 176 | 177 | 178 | END SUBROUTINE DoReorient 179 | 180 | !***********************************************************************! 181 | ! ! 182 | ! SUBROUTINE FSINIT ! 183 | !-----------------------------------------------------------------------! 184 | ! Initialises FASOLT 3 and gets control data ! 185 | !-----------------------------------------------------------------------! 186 | ! ! 187 | !***********************************************************************! 188 | SUBROUTINE FSINIT 189 | 190 | USE FAS_COM ! FASOLT main variables declaration 191 | 192 | IMPLICIT NONE 193 | 194 | INTEGER(4) iomon, in, out, ierr 195 | 196 | COMMON/ iochan/ iomon, in, out 197 | 198 | CHARACTER(100) :: dir,dir1,dir2,dir3,dir4,fname 199 | !----------------------------------------integer channel numbers 200 | iomon= 51 201 | in= 52 202 | out= 53 203 | 204 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 205 | IF ( ierr .EQ. 0 ) THEN 206 | READ(in,*) dir1,dir2,dir3,dir4,dir 207 | ELSE 208 | WRITE(*,'("No dirname file found. Path is current directory.")') 209 | dir='./' 210 | END IF 211 | CLOSE(in) 212 | 213 | fname=TRIM(dir)//'fafcdf.dat' 214 | 215 | OPEN( UNIT=in, FILE=fname) 216 | READ( in, *) toler, maxit, alpha, afactor 217 | READ( in, *) efix, smalp, smalf 218 | READ( in, *) smald, smale, smalr 219 | CLOSE( in) 220 | 221 | END SUBROUTINE FSINIT 222 | 223 | !***********************************************************************! 224 | ! ! 225 | ! SUBROUTINE UPDATE-NODE ! 226 | !-----------------------------------------------------------------------! 227 | ! Updates relevant variables at START of incremental solution. ! 228 | !-----------------------------------------------------------------------! 229 | ! ! 230 | !***********************************************************************! 231 | SUBROUTINE UPDATE_NODE 232 | 233 | USE FAS_COM ! FASOLT main variables declaration 234 | 235 | IMPLICIT NONE 236 | INTEGER(4) ndof 237 | 238 | ndof= 3*nnod 239 | x(1:ndof)=x(1:ndof) + dx(1:ndof) ! update node positions 240 | 241 | !---------------------------------------Update die positions 242 | 243 | 244 | END SUBROUTINE UPDATE_NODE 245 | 246 | !***********************************************************************! 247 | ! ! 248 | ! SUBROUTINE UPDATE-GPTV ! 249 | !-----------------------------------------------------------------------! 250 | ! Updates relevant variables at END of incremental solution. ! 251 | !-----------------------------------------------------------------------! 252 | ! ! 253 | !***********************************************************************! 254 | SUBROUTINE UPDATE_GPTV 255 | 256 | USE FAS_COM ! FASOLT main variables declaration 257 | 258 | IMPLICIT NONE 259 | 260 | INTEGER(4) i, j 261 | 262 | !-------------------------------------update all Gauss point values 263 | DO i= 1, ngps 264 | 265 | eps( i)= eps( i) + dep( i) 266 | DO j=1,3 267 | rt( j, i)= rt( j, i) + dr( j, i) ! update rotation vector 268 | END DO 269 | 270 | DO j=1,6 271 | ep( j, i)= ep( j, i) + de( j, i) 272 | st( j, i)= st( j, i) + ds( j, i) 273 | END DO 274 | 275 | DO j=1,nsv 276 | sv( j, i)= sv( j, i) + dsv( j, i) ! update Euler angles (+ slip resistances) 277 | END DO 278 | 279 | END DO 280 | 281 | !--------------------------------dump selected Gauss point values 282 | 283 | 284 | END SUBROUTINE UPDATE_GPTV 285 | 286 | !***********************************************************************! 287 | ! ! 288 | ! SUBROUTINE FAFERR(IER) ! 289 | !-----------------------------------------------------------------------! 290 | ! -Error reporting routine with possible dump and stop ! 291 | !-----------------------------------------------------------------------! 292 | ! Arguments ier INTEGER, Error code: ! 293 | ! ier>500 fatal ! 294 | ! ier<500 warning ! 295 | ! ier>900 fatal, dump ! 296 | !-----------------------------------------------------------------------! 297 | ! ! 298 | !***********************************************************************! 299 | SUBROUTINE FAFERR(ier) 300 | 301 | IMPLICIT NONE 302 | 303 | INTEGER(4) iomon, in, out, ier 304 | 305 | COMMON/ iochan/ iomon, in, out 306 | 307 | SELECT CASE (ier) 308 | 309 | CASE (:500) 310 | WRITE(iomon, '(/,10X,'' *** FAFNER: WARNING, '',I3,/)') ier 311 | WRITE(* , '(/,10X,'' *** FAFNER: WARNING, '',I3,/)') ier 312 | 313 | CASE (501:) 314 | WRITE(iomon, '(/,10X,'' *** FAFNER: FATAL ERROR, '',I3,/)') ier 315 | WRITE(* , '(/,10X,'' *** FAFNER: FATAL ERROR, '',I3,/)') ier 316 | 317 | IF ( ier .GT. 900 ) CALL WTDATA('faferr.frs') 318 | WRITE(*,'(10x,''any key to finish..'',\)') 319 | READ(*,*) 320 | STOP 321 | END SELECT 322 | 323 | END SUBROUTINE FAFERR 324 | 325 | -------------------------------------------------------------------------------- /src/fasolt/Sig_eps.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! sig_eps: Routines for strain and rotations, stress and ds/de ! 4 | ! ! 5 | !***********************************************************************! 6 | 7 | !***********************************************************************! 8 | ! ! 9 | ! SUBROUTINE DSTRNS(np,sfd,dx,de,r,deff) ! 10 | !-----------------------------------------------------------------------! 11 | ! - Linear approximations to the strains and plane rigid ! 12 | ! body rotation increments at an integration point. ! 13 | !-----------------------------------------------------------------------! 14 | ! Arguements npl INTEGER; No. of s.f.d's (nodes) involved ! 15 | ! sfd REAL ARRAY(1:3,1:NP); S.F.D's ! 16 | ! dxl REAL ARRAY(1:NP,1:3); Displacements at nodes ! 17 | ! del REAL ARRAY(1:6); Strain increments ! 18 | ! rl REAL ARRAY(1:3); Rotation increments ! 19 | ! deff REAL; von Mises effective value of de ! 20 | !-----------------------------------------------------------------------! 21 | ! Note conventions: r; anticlockwise about X, Y, Z ! 22 | ! de; 11, 22, 33, 23, 31, 12 Shears doubled ! 23 | ! ! 24 | !***********************************************************************! 25 | SUBROUTINE DSTRNS(npl, sfd, dxl, del, rl, deff) 26 | 27 | USE FAS_COM ! FASOLT main variables declaration 28 | 29 | IMPLICIT NONE 30 | 31 | INTEGER(4) npl 32 | REAL(4) sfd, dxl, del, rl, deff, ddxl 33 | INTEGER(4) i, j, k 34 | REAL(4) sum, FJ2VOM 35 | 36 | DIMENSION sfd( 1:3, 1:npl), dxl( 1:3, 1:npl), del( 1:6), rl( 1:3) 37 | DIMENSION ddxl( 1:3, 1:3) 38 | 39 | 40 | ddxl= MATMUL( sfd, TRANSPOSE(dxl)) ! Displacement gradients 41 | 42 | sum= 0. 43 | DO i= 1, 3 44 | j= 1 + mod(i,3) 45 | k= 1 + mod(j,3) 46 | !------------------------------------------strains 47 | del(i)= ddxl(i,i) 48 | del(i+3)= ( ddxl(k,j) + ddxl(j,k) ) 49 | !------------------------------------------rotations 50 | rl(i)= ( ddxl(k,j) - ddxl(j,k) )/2. 51 | sum= sum +rl(i)*rl(i) 52 | END DO 53 | 54 | !----------von Mises effective value of increment and test 55 | deff= FJ2VOM(.FALSE.,del) 56 | 57 | !----------------------------------------test magnitudes 58 | IF( sum .GT. smalr) CALL FAFERR(905) 59 | IF( deff .GT. smale) CALL FAFERR(906) 60 | 61 | END SUBROUTINE DSTRNS 62 | 63 | !***********************************************************************! 64 | ! ! 65 | ! SUBROUTINE DSTRSS(iel,jgp,deff,es,de,st,ds,t,r,d) ! 66 | !-----------------------------------------------------------------------! 67 | ! -Determination of stresses and optional modulii along with ! 68 | ! rotational modifications to stress and strain. Stresses are ! 69 | ! calculated for crystal plasticity, the modulii are derivatives ! 70 | ! for use in Newton-Raphson scheme. ! 71 | !-----------------------------------------------------------------------! 72 | ! Arguments: iel INTEGER, Element property code ! 73 | ! jgp INTEGER, Integration point number ! 74 | ! deff REAL, Increment effective plastic strain ! 75 | ! es,de REAL ARRAYS(1:6),Total strains, strain incs., ! 76 | ! st,ds total stresses and stress ! 77 | ! incs. Order: 11,22,33,23,31,12 ! 78 | ! r REAL ARRAY(1:3), R.B. Rotation (anticl. 1,2,3) ! 79 | ! chi REAL ARRAY(1:6, 1:6), Modulii ! 80 | ! t REAL ARRAY(1:6), At return temp. updated stress ! 81 | !-----------------------------------------------------------------------! 82 | ! ! 83 | !***********************************************************************! 84 | SUBROUTINE DSTRSS( iel, jgp, deff, es, de, st, ds, t, r, chi) 85 | 86 | USE FAS_CPL !material property module 87 | 88 | IMPLICIT NONE 89 | 90 | INTEGER(4) iel, jgp 91 | REAL(4) deff, d 92 | 93 | INTEGER(4) i, j, ifail 94 | REAL(4) sinit, einit 95 | REAL(4) FJ2VOM 96 | 97 | REAL(4), DIMENSION( 1:3):: r 98 | REAL(4), DIMENSION( 1:6):: es, de, st, ds, t, ep, s 99 | REAL(4), DIMENSION( 1:6, 1:6):: chi, el_comp 100 | 101 | mat_code= ABS(iel) ! material property set pointer 102 | 103 | CALL ELASTC( jgp, el_comp) ! Get elastic compliances 104 | 105 | CALL TENS_ROT(r,st,t) ! Total start stresses in updated frame 106 | 107 | s= t + ds ! Initial guess plastic state using existing stress 108 | sinit= FJ2VOM(.TRUE., s) 109 | einit= FJ2VOM(.FALSE.,de) 110 | 111 | 112 | !-----------------------------------------Test for elastic only solution 113 | IF ( iel.GT.0 .AND. sinit.GT.0. .AND. einit.GT.0. ) THEN !Plastic 114 | 115 | CALL CPSTRS(jgp,el_comp,de,r,s,t,ep,chi) 116 | 117 | !--------Transfer s to t stress,get eff. strain increment 118 | t= s 119 | deff=FJ2VOM(.FALSE.,ep) 120 | 121 | !--------------Symmetrised elasto-plastic matrix 122 | DO i= 1, 6 123 | DO j= i, 6 124 | d=( chi(i,j) + chi(j,i) )/2. 125 | chi(i,j)=d 126 | chi(j,i)=d 127 | END DO 128 | END DO 129 | 130 | ELSE ! Elastic only solution 131 | 132 | deff=0. 133 | 134 | CALL FACTOR(6,el_comp,ifail) 135 | DO i=1,6 136 | ep(1:6)=0. 137 | ep(i) = 1. 138 | CALL SOLVER(6,el_comp,ep) 139 | DO j=1,6 140 | chi(j,i)= ep(j) 141 | END DO 142 | END DO 143 | 144 | t= MATMUL( chi, de) 145 | 146 | END IF 147 | 148 | ds= t - st ! Stress increments 149 | 150 | 151 | END SUBROUTINE DSTRSS 152 | 153 | !***********************************************************************! 154 | ! ! 155 | ! SUBROUTINE TENS_ROT(r,a,b) ! 156 | !-----------------------------------------------------------------------! 157 | ! Routine to rotate symmetrical 3x3 tensor, in compact notation. ! 158 | !-----------------------------------------------------------------------! 159 | ! Arguments: r REAL ARRAY(1:3); small rotations about x,y,z ! 160 | ! a REAL ARRAY(1:6); initial basis tensor ! 161 | ! b REAL ARRAY(1:6); rotated basis tensor ! 162 | !-----------------------------------------------------------------------! 163 | ! NB The condensed tensor is tensor form i.e. not doubled shears ! 164 | ! ! 165 | !***********************************************************************! 166 | SUBROUTINE TENS_ROT( r, a, b) 167 | 168 | IMPLICIT NONE 169 | 170 | INTEGER(4) i, j, k 171 | REAL(4) r, a, b, rot, old, new 172 | 173 | DIMENSION r( 1:3), a( 1:6), b( 1:6) 174 | DIMENSION rot( 1:3, 1:3), old( 1:3, 1:3), new( 1:3, 1:3) 175 | 176 | !------------------------------------allocate to full arrays 177 | DO i= 1, 3 178 | j= 1 + MOD(i,3) 179 | k= 1 + MOD(j,3) 180 | 181 | old(i,i)= a(i) 182 | old(j,k)= a(i+3) 183 | old(k,j)= old(j,k) 184 | 185 | rot(j,k)= r(i) 186 | rot(k,j)= -r(i) 187 | rot(i,i)= SQRT( 1. - r(j)*r(j) -r(k)*r(k) ) 188 | END DO 189 | 190 | !---------------------------------------rotate basis 191 | new= MATMUL(TRANSPOSE(rot), MATMUL(old, rot) ) 192 | 193 | !------------------------------------condense result 194 | DO i= 1, 3 195 | j= 1 + MOD(i,3) 196 | k= 1 + MOD(j,3) 197 | 198 | b(i) = new(i,i) 199 | b(i+3)= new(j,k) 200 | END DO 201 | 202 | END SUBROUTINE TENS_ROT 203 | 204 | !***********************************************************************! 205 | ! ! 206 | ! REAL FUNCTION FJ2VOM( lstress, x) ! 207 | ! ! 208 | !-----------------------------------------------------------------------! 209 | ! Von Mises effective value, for variables which can include ! 210 | ! hydrostatic, of either stress or strain (eng. shear strain) ! 211 | !-----------------------------------------------------------------------! 212 | ! Arguments lstress LOGICAL; TRUE if stresses ! 213 | ! x REAL ARRAY(1:6); Stress or strain values ! 214 | !-----------------------------------------------------------------------! 215 | ! ! 216 | !***********************************************************************! 217 | REAL FUNCTION FJ2VOM( lstress, x) 218 | 219 | IMPLICIT NONE 220 | 221 | LOGICAL(4) lstress 222 | INTEGER(4) i, j 223 | REAL(4) x, sum, amult 224 | 225 | DIMENSION x( 1:6) 226 | 227 | IF ( lstress ) THEN 228 | amult= 6.0 229 | ELSE 230 | amult= 1.5 231 | ENDIF 232 | 233 | sum=0. 234 | DO i= 1, 3 235 | j= 1 + MOD(i,3) 236 | sum= sum +(x(i)-x(j))*(x(i)-x(j)) + amult*x(i+3)*x(i+3) 237 | END DO 238 | 239 | FJ2VOM= SQRT( sum /4.5) 240 | 241 | END FUNCTION FJ2VOM 242 | -------------------------------------------------------------------------------- /src/fasolt/Stif_sol.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE NRITER ! 4 | !-----------------------------------------------------------------------! 5 | ! Damped Newton-Raphson iteration for solution ! 6 | ! of deformation over a single increment. ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | SUBROUTINE NRITER 11 | 12 | USE FAS_COM ! FASOLT main variables declaration 13 | USE FAS_CPL ! Crystal plasticity variables 14 | 15 | IMPLICIT NONE 16 | 17 | LOGICAL(4) l_conv 18 | INTEGER(4) nit, ndof, i, igp, iop 19 | REAL(4) sfc, erddx, errdx, alp2, xc, sdx 20 | 21 | !---------------------------------------Common for sum of iteration error 22 | REAL(4) sumcpiter 23 | COMMON/ CPITER / sumcpiter 24 | 25 | !--------------------write header to monitor report 26 | CALL ITHEAD(inc) 27 | !--------------------------Initiate repeat sequence 28 | ndof=3*nnod 29 | nit= 0 30 | l_conv= .TRUE. 31 | 32 | DO WHILE(l_conv) 33 | nit= nit + 1 34 | 35 | sumcpiter= 0. ! initialise CP iteration error sum 36 | 37 | !-------------------Initialise mechanical arrays 38 | fc(1:ndof)= 0. 39 | ss( 1:1000, 1:ndof)= 0. 40 | 41 | !------------------Form equations for the corrections 42 | CALL ELVALS 43 | CALL SUVALS 44 | 45 | !------------------Get internal imbalances of F 46 | sfc=0. 47 | DO i= 1, nnod 48 | IF ( ib(i).LT.10 ) sfc=sfc + ddx(3*i-2)*ddx(3*i-2) + & 49 | & ddx(3*i-1)*ddx(3*i-1) + ddx(3*i)*ddx(3*i) 50 | END DO 51 | sfc= SQRT(sfc) 52 | !-----------------------------------------------Solve 53 | CALL FACSLS(ndof) 54 | 55 | !-------Calculate displacement error and damping parameter 56 | errdx=SQRT( DOT_PRODUCT( dx(1:ndof), dx(1:ndof)) ) 57 | erddx=SQRT( DOT_PRODUCT(ddx(1:ndof),ddx(1:ndof)) ) 58 | IF( errdx .EQ. 0. ) THEN 59 | sdx= toler 60 | ELSE 61 | sdx= erddx/errdx 62 | ENDIF 63 | alp2=1./(1.+alpha*sdx) 64 | 65 | sumcpiter= sumcpiter/ REAL( ngps, 4) 66 | 67 | CALL ITEREP(nit,sdx,sfc,sumcpiter,alp2) !iteration progress report 68 | 69 | !------------------------------Correct incremental values 70 | DO i= 1, ndof 71 | xc= alp2*ddx(i) 72 | x(i)= x(i) - xc 73 | dx(i)= dx(i) - xc 74 | END DO 75 | 76 | l_conv= (sdx.GE.toler).AND.(nit.LT.maxit) 77 | END DO 78 | 79 | ! update cumslip variable here: 80 | do igp=1, ngps 81 | do iop=1,nss(mat_code) 82 | cumslip(iop, igp) = cumslip(iop, igp) + (srate(iop, igp) * tiem(inc)) ! slip added up 83 | end do 84 | end do 85 | 86 | CALL POWER ! report power 87 | 88 | END SUBROUTINE NRITER 89 | 90 | !***********************************************************************! 91 | ! ! 92 | ! SUBROUTINE SETPTA ! 93 | !-----------------------------------------------------------------------! 94 | ! Generation of pointer arrays for compact storage of stiffness ! 95 | !-----------------------------------------------------------------------! 96 | ! ! 97 | !***********************************************************************! 98 | SUBROUTINE SETPTA 99 | 100 | USE FAS_COM ! FASOLT main variables declaration 101 | 102 | IMPLICIT NONE 103 | 104 | LOGICAL(4) new 105 | INTEGER(4) ilmnt, i, j, k, js, ks, locpoint, row, column, noffdiag 106 | DIMENSION locpoint(1: maxofd) 107 | 108 | is(1:maxofd,1:3*nnod) = 0 ! initialise pointer 109 | 110 | DO ilmnt= 1, nlmnt ! loop on elements 111 | 112 | DO i= 1, nd(ilmnt) ! loop on its nodes, form DOF array 113 | DO j= -2, 0 114 | locpoint( 3*i + j) = 3*ln(i,ilmnt) + j 115 | END DO 116 | END DO 117 | 118 | DO i= 1, 3*nd(ilmnt) ! loop on pointer row dof 119 | row= locpoint(i) 120 | 121 | DO j= 1, 3*nd(ilmnt) 122 | column=locpoint(j) 123 | 124 | IF( row .NE. column ) THEN ! loop, off-diagonal column dofs 125 | 126 | new=.TRUE. ! check if already in list 127 | DO k= 2, 1 + is( 1, row ) 128 | IF( is( k, row) .EQ. column) new=.FALSE. 129 | END DO 130 | 131 | IF ( new ) THEN ! not in list, add 132 | noffdiag= is(1,row) + 1 133 | 134 | IF (noffdiag .GT. maxofd) CALL FAFERR(955) 135 | 136 | is( 1, row)= noffdiag 137 | is( 1+noffdiag, row)= column 138 | END IF 139 | 140 | END IF 141 | 142 | END DO 143 | 144 | 145 | END DO 146 | 147 | END DO 148 | 149 | END SUBROUTINE SETPTA 150 | 151 | !***********************************************************************! 152 | ! ! 153 | ! SUBROUTINE FACSLS(M) ! 154 | !-----------------------------------------------------------------------! 155 | ! Solution of linear equations using SOR ! 156 | !-----------------------------------------------------------------------! 157 | ! ARGUMENTS m INTEGER, SIZE OF R.H.S VECTOR ! 158 | !-----------------------------------------------------------------------! 159 | ! ! 160 | !***********************************************************************! 161 | SUBROUTINE FACSLS(m) 162 | 163 | USE FAS_COM ! FASOLT main variables declaration 164 | 165 | IMPLICIT NONE 166 | 167 | LOGICAL(4) conv 168 | INTEGER(4) m, iter, maxitl, i, j 169 | REAL(4) tolerl, alphal, y, dxl, error 170 | REAL(4) sum 171 | DIMENSION y(1:maxdof), dxl(1:maxdof) 172 | 173 | DATA alphal, maxitl/ 1.2, 1000/ 174 | 175 | tolerl= toler*toler 176 | 177 | !---------allocate lhs and rhs vectors, set convergence flag 178 | y(1:m)= ddx(1:m) 179 | ddx(1:m)= 0. 180 | conv= .FALSE. 181 | 182 | !---------------------------------------------test diagonals 183 | DO i= 1, m 184 | IF ( ABS( ss(1,i)) .EQ. 0.) CALL FAFERR(903) 185 | END DO 186 | 187 | !----------------------------------------------------iterate 188 | iter=0 189 | DO WHILE( (.NOT. conv) .AND. (iter.LT.maxitl)) 190 | iter= iter + 1 191 | dxl(1:m)= ddx(1:m) ! store old x 192 | 193 | DO i= 1, m ! sweep on rows 194 | 195 | !------------go sideways to get off-diagonal a.x terms 196 | sum=0.D0 197 | DO j=2, 1 + is(1,i) 198 | sum= sum + ss(j,i)*ddx(is(j,i)) 199 | END DO 200 | 201 | !------------------get change term, add weighted value 202 | sum=( y(i) - sum )/ss(1,i) 203 | ddx(i)= ddx(i)+ alphal*( sum - ddx(i)) 204 | 205 | END DO 206 | 207 | !--------------------get change in x, test convergence 208 | dxl= ddx- dxl 209 | error= DOT_PRODUCT(dxl,dxl)/DOT_PRODUCT(ddx,ddx) 210 | conv= ( error .LT. tolerl ) 211 | END DO 212 | 213 | IF ( error .GT. 10.*tolerl) CALL FAFERR(904) ! convergence fail 214 | 215 | END SUBROUTINE FACSLS 216 | 217 | -------------------------------------------------------------------------------- /src/fasolt/crys-cons.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! Fasolt3 -crys_cons ! 4 | ! Pete Bate 2000 ! 5 | !-----------------------------------------------------------------------! 6 | ! Crystal plasticity routines for 3-d FEM ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | 11 | !***********************************************************************! 12 | ! ! 13 | ! SUBROUTINE SLPFTA( dt) ! 14 | !-----------------------------------------------------------------------! 15 | ! Routine for the slip increments for a given orientation and slip ! 16 | ! stresses, by Newton-Raphson on the log.-log. basis. This version ! 17 | ! tests for the absolute change in slips and returns the augmented ! 18 | ! visco-plastic hardening matrix (X) ! 19 | !-----------------------------------------------------------------------! 20 | ! Arguments: dt REAL; Time step ! 21 | !-----------------------------------------------------------------------! 22 | ! ! 23 | !***********************************************************************! 24 | SUBROUTINE SLPFTA( dt) 25 | 26 | USE FAS_COM ! FASOLT main variables declaration 27 | USE FAS_CPL ! Crystal plasticity variables 28 | 29 | IMPLICIT NONE 30 | 31 | INTEGER(4) jgp 32 | REAL(4) dt 33 | 34 | LOGICAL(4) l_iter 35 | INTEGER(4) i, j, ii, jj, iter, ifail 36 | REAL(4) facmax, tiny, conv, gamn, taufg 37 | REAL(4) tauerr, errmax, scale, SPOWER 38 | 39 | REAL(4), DIMENSION(1:nss(mat_code)):: am 40 | REAL(4), DIMENSION(1:nsa):: errtau 41 | 42 | DATA facmax, tiny/ 5., 1.E-12/ ! Other data 43 | 44 | !---------------------------------------------Tolerance for slip stress convergence 45 | conv= toler*MAXVAL(ampar(1,1:nss(mat_code),mat_code)) 46 | 47 | !------------------------------------------------------Iteration for slip increments 48 | iter=0 49 | l_iter= .TRUE. 50 | 51 | DO WHILE( l_iter) 52 | iter= iter + 1 53 | CALL PLASTC( dt, am) ! Hardening update 54 | 55 | !------------------------------------Complete log. slip ah matrix and factor 56 | DO i= 1, nsa 57 | ii=isa(i) 58 | gamn= gam(ii) 59 | DO j= 1, nsa 60 | ah(j,i)= gamn*ah(j,i) 61 | END DO 62 | ah(i,i)= ah(i,i) + am(ii) 63 | END DO 64 | 65 | CALL FACTOR( nsa, ah(1:nsa,1:nsa), ifail) 66 | IF (ifail .EQ. 1 ) CALL FAFERR(910) 67 | 68 | !-----------------------------------Form the error in slip stress 69 | DO i= 1, nsa 70 | ii= isa(i) 71 | taufg= s1(ii) * SPOWER( ( gam(ii)/dt ), am(ii)) 72 | IF ((tau(ii)*taufg) .GT. 0.) THEN 73 | errtau(i)= ALOG( tau(ii)/taufg ) 74 | ELSE 75 | errtau(i)= 0. 76 | ENDIF 77 | END DO 78 | 79 | !--------------------------------RMS value of slip stress error 80 | tauerr= 0. 81 | DO i=1,nsa 82 | tauerr=tauerr+errtau(i)*errtau(i) 83 | END DO 84 | tauerr=SQRT(tauerr) 85 | 86 | !--------------------------------Correction to slip increment, cap 87 | CALL SOLVER( nsa, ah(1:nsa,1:nsa), errtau(1:nsa)) 88 | errmax=0. 89 | DO i= 1, nsa 90 | IF ( ABS(errtau(i)) .GT. errmax ) errmax= ABS(errtau(i)) 91 | END DO 92 | 93 | IF (errmax .GT. facmax) THEN 94 | scale= facmax/errmax 95 | ELSE 96 | scale= 1. 97 | ENDIF 98 | !--------------------------------Update slip increment estimate 99 | DO i= 1, nsa 100 | ii=isa(i) 101 | gam(ii)= gam(ii)*EXP(scale*errtau(i)) 102 | END DO 103 | 104 | l_iter= (iter .LT. maxit) .AND. (tauerr .GT. conv) 105 | 106 | END DO 107 | 108 | IF (tauerr .GT. 0.5) CALL FAFERR(987) !fail, too big an error 109 | 110 | !--------------------Get and complete ah matrix in X visco-plastic form 111 | CALL PLASTC( dt, am) 112 | 113 | DO i= 1, nsa 114 | ii= isa(i) 115 | DO j=1, nsa 116 | jj= isa(j) 117 | ah(j,i)= tau(jj)*ah(j,i) 118 | END DO 119 | 120 | IF ( ABS(gam(ii)) .GT. tiny ) THEN 121 | ah(i,i)=ah(i,i) + am(ii)*tau(ii)/gam(ii) 122 | ELSE 123 | ah(i,i)=ah(i,i) + am(ii)/tiny 124 | ENDIF 125 | 126 | END DO 127 | 128 | END SUBROUTINE SLPFTA 129 | 130 | !***********************************************************************! 131 | ! ! 132 | ! SUBROUTINE SLPINI( dt, am) ! 133 | ! ! 134 | !-----------------------------------------------------------------------! 135 | ! Routine for slip increments from tau for given resistances ! 136 | ! with a cut-off for small relative slip increments to zero. ! 137 | !-----------------------------------------------------------------------! 138 | ! Arguments: dt REAL; Time step ! 139 | ! am REAL; Rate sensitivity index ! 140 | !-----------------------------------------------------------------------! 141 | ! ! 142 | !***********************************************************************! 143 | SUBROUTINE SLPINI(jgp, dt, am) 144 | 145 | USE FAS_COM ! FASOLT main variables declaration 146 | USE FAS_CPL ! Crystal plasticity variables 147 | 148 | IMPLICIT NONE 149 | 150 | REAL(4) dt, twinrn 151 | 152 | INTEGER(4) i, jgp 153 | REAL(4) cofact, gammax, cutoff, SPOWER 154 | REAL(4), DIMENSION(1:nss(mat_code)):: am 155 | 156 | 157 | DATA cofact/1.E-6/ ! Relative slip cut-off to zero 158 | 159 | am(1:nss(mat_code))=ampar(1,1:nss(mat_code),mat_code) ! Rate sensitivities 160 | 161 | !--------------------------Get slip increments and maximum absolute value 162 | gammax= 0. 163 | DO i= 1, nss(mat_code) 164 | 165 | IF ( abs(ssang(i,mat_code)) .gt. 1.5 ) THEN ! twin system, don't allow slip, just reorient! 166 | gam(i)= 0. 167 | ! check if twin crit. fulfilled (RSS > CRSS) and (not yet reached num. limit) and (not twinning on other sys.): 168 | if ( ((tau(i) .gt. s0(i)) .and. (timestwinned(jgp) .ne. twinlim) .and. (twinsys(jgp) .eq. 0)) ) then 169 | CALL RANDOM_NUMBER(twinrn) 170 | if (twinrn .lt. twinprob) then 171 | tflag = 1 172 | twinsys(jgp) = i 173 | end if 174 | end if 175 | ELSE IF ( ssang(i,mat_code)*tau(i)/s0(i) .LT. 0. ) THEN ! if ssang=1, don't allow slip for negative tau/s0! 176 | gam(i)= 0. 177 | ELSE 178 | gam(i)=dt*SPOWER((tau(i)/s0(i)),(1./am(i))) 179 | ENDIF 180 | 181 | 182 | IF ( ABS( gam(i) ) .GT. gammax ) gammax=ABS(gam(i)) 183 | END DO 184 | 185 | !---------Cut off 'inactive' systems, form pointer and scale slips 186 | cutoff= cofact*gammax 187 | nsa= 0 188 | DO i= 1, nss(mat_code) 189 | IF ( ABS(gam(i)) .LT. cutoff ) THEN 190 | gam(i)= 0. 191 | ELSE 192 | nsa= nsa +1 193 | isa(nsa)= i 194 | ENDIF 195 | END DO 196 | 197 | END SUBROUTINE SLPINI 198 | 199 | !***********************************************************************! 200 | ! ! 201 | ! REAL FUNCTION SPOWER( a, b) ! 202 | !-----------------------------------------------------------------------! 203 | ! Function for signed power with traps ! 204 | !-----------------------------------------------------------------------! 205 | ! Arguments: a REAL ; argument ! 206 | ! b REAL ; exponent ! 207 | !-----------------------------------------------------------------------! 208 | ! ! 209 | !***********************************************************************! 210 | REAL FUNCTION SPOWER( a, b) 211 | 212 | IMPLICIT NONE 213 | 214 | REAL(4) a, b 215 | 216 | REAL(4) aa, allm, bllm, sparg 217 | DATA allm, bllm/ 80.0, 1.E-35/ 218 | 219 | aa=ABS(a) 220 | 221 | IF ( aa .LT. bllm ) THEN 222 | SPOWER=0. 223 | ELSE 224 | sparg= b* ALOG(aa) 225 | IF (sparg .LT. -allm) sparg= -allm 226 | IF (sparg .GT. allm) sparg= allm 227 | SPOWER=SIGN(EXP(sparg), a) 228 | ENDIF 229 | 230 | END FUNCTION SPOWER 231 | 232 | !***********************************************************************! 233 | ! ! 234 | ! SUBROUTINE FACTOR( n, w, ifail) ! 235 | ! ! 236 | !-----------------------------------------------------------------------! 237 | ! -LU Factoring of square matrix, no frills! ! 238 | !-----------------------------------------------------------------------! 239 | ! Arguments: n INTEGER, Order of matrix ! 240 | ! w REAL ARRAY(1:n,1:n); Matrix, LU factored on exit ! 241 | ! ifail INTEGER, IF 0 OK ELSE indeterminate ! 242 | ! ! 243 | !***********************************************************************! 244 | SUBROUTINE FACTOR( n, w, ifail) 245 | 246 | IMPLICIT NONE 247 | 248 | INTEGER(4) n, ifail 249 | REAL(4) w 250 | INTEGER(4) i, j, k 251 | 252 | DIMENSION w( 1:n, 1:n) 253 | 254 | ifail=1 255 | DO k= 1, n-1 256 | DO i= k+1, n 257 | IF ( w(k,k) .EQ. 0. ) RETURN 258 | w(i,k)= w(i,k)/w(k,k) 259 | DO j= k+1, n 260 | w(i,j)=w(i,j) - w(i,k)*w(k,j) 261 | END DO 262 | END DO 263 | END DO 264 | 265 | IF ( w(n,n) .EQ. 0. ) RETURN 266 | 267 | ifail=0 268 | 269 | END SUBROUTINE FACTOR 270 | 271 | !***********************************************************************! 272 | ! ! 273 | ! SUBROUTINE SOLVER( n, w, x) ! 274 | ! ! 275 | !-----------------------------------------------------------------------! 276 | ! -Linear equation solution given LU factored matrix ! 277 | !-----------------------------------------------------------------------! 278 | ! Arguments: n INTEGER, Order of matrix ! 279 | ! w REAL ARRAY(1:n,1:n); LU factored matrix ! 280 | ! x REAL ARRAY(n); LHS on entry, solution on exit ! 281 | ! ! 282 | !***********************************************************************! 283 | SUBROUTINE SOLVER( n, w, x) 284 | 285 | IMPLICIT NONE 286 | 287 | INTEGER(4) n 288 | REAL(4) w, x 289 | 290 | INTEGER(4) i, j 291 | 292 | DIMENSION w(1:n,1:n),x(1:n) 293 | 294 | DO i= 2, n 295 | DO j= 1, i-1 296 | x(i)=x(i) - w(i,j)*x(j) 297 | END DO 298 | END DO 299 | 300 | x(n)=x(n)/w(n,n) 301 | 302 | DO i= n-1, 1, -1 303 | DO j= i+1, n 304 | x(i)= x(i) - w(i,j)*x(j) 305 | END DO 306 | x(i)= x(i)/w(i,i) 307 | END DO 308 | 309 | END SUBROUTINE SOLVER 310 | 311 | -------------------------------------------------------------------------------- /src/fasolt/crys_math.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! Fasolt3 -crys_math ! 4 | ! Pete Bate 2000 ! 5 | !-----------------------------------------------------------------------! 6 | ! Crystal routines for 3-d FEM ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | ! 11 | !! SLPTAU(SIG,B,TAU) REPLACABLE BY TAU= MATMUL(TRANSPOSE(B),SIG) 12 | 13 | !! SLPEPS(EPS,B,GAM) REPLACABLE BY EPS= MATMUL(B,GAM) 14 | 15 | ! 16 | !***********************************************************************! 17 | ! ! 18 | ! SUBROUTINE CTMATRX(ph1,phi,ph2,a) ! 19 | !-----------------------------------------------------------------------! 20 | ! Orientation matrix, a, from Euler angles (in radians) and ! 21 | ! augment terms used for angle change calculations. ! 22 | !-----------------------------------------------------------------------! 23 | ! ! 24 | !***********************************************************************! 25 | SUBROUTINE CTMATRX( ph1, phi, ph2, a, aug) 26 | 27 | IMPLICIT NONE 28 | 29 | REAL(4) ph1, phi, ph2, a, aug 30 | REAL(4) c, s, c1, c2,s1, s2, c1c2, c1s2, s1c2, s1s2 31 | 32 | DIMENSION a(1:3,1:3), aug( 1:3) 33 | 34 | !-----------------------------Form trig function terms 35 | c1= COS(ph1) 36 | s1= SIN(ph1) 37 | c2= COS(ph2) 38 | s2= SIN(ph2) 39 | c= COS(phi) 40 | s= SIN(phi) 41 | c1c2=c1*c2 42 | s1s2=s1*s2 43 | c1s2=c1*s2 44 | s1c2=s1*c2 45 | 46 | !---------------------------Form the transform matrix 47 | a(1,1)= c1c2 - s1s2*c 48 | a(2,1)=-c1s2 - s1c2*c 49 | a(3,1)= s1*s 50 | a(1,2)= s1c2 + c1s2*c 51 | a(2,2)=-s1s2 + c1c2*c 52 | a(3,2)=-c1*s 53 | a(1,3)= s2*s 54 | a(2,3)= c2*s 55 | a(3,3)= c 56 | 57 | !------Extra terms for orientation change calculations 58 | aug(1)=s2 59 | aug(2)=c2 60 | aug(3)=s 61 | 62 | END SUBROUTINE CTMATRX 63 | 64 | !***********************************************************************! 65 | ! ! 66 | ! SUBROUTINE BTMATRX( a) ! 67 | !-----------------------------------------------------------------------! 68 | ! Routine for the slip rate to strain rate and spin matrices ! 69 | ! in the current orientation, given by three Euler angles. ! 70 | !-----------------------------------------------------------------------! 71 | ! Note conventions: r; anticlockwise about X, Y, Z ! 72 | ! de; 11, 22, 33, 23, 31, 12 ! 73 | ! ! 74 | !***********************************************************************! 75 | SUBROUTINE BTMATRX( a ) 76 | 77 | USE FAS_CPL 78 | 79 | IMPLICIT NONE 80 | 81 | REAL(4) a 82 | INTEGER(4) i, j, l 83 | REAL(4) sdr, spn, sum1, sum2 84 | 85 | DIMENSION a( 1:3, 1:3), sdr( 1:3), spn( 1:3) 86 | 87 | !------------------------------Form the slip rate to strain rate matrix 88 | DO i=1,nss(mat_code) 89 | DO j=1,3 90 | sum1= 0. 91 | sum2= 0. 92 | DO l=1,3 93 | sum1= sum1 + a(l,j)*ab(l,i,mat_code) 94 | sum2= sum2 + a(l,j)*an(l,i,mat_code) 95 | END DO 96 | sdr(j)=sum1 97 | spn(j)=sum2 98 | END DO 99 | 100 | b(1,i)= sdr(1)*spn(1) 101 | b(2,i)= sdr(2)*spn(2) 102 | b(3,i)= sdr(3)*spn(3) 103 | b(4,i)= sdr(2)*spn(3) + sdr(3)*spn(2) 104 | b(5,i)= sdr(3)*spn(1) + sdr(1)*spn(3) 105 | b(6,i)= sdr(1)*spn(2) + sdr(2)*spn(1) 106 | 107 | !------------------------------and the slip rate to global spin matrix 108 | 109 | rot(1,i)=( sdr(2)*spn(3)-sdr(3)*spn(2) )/2. 110 | rot(2,i)=( sdr(3)*spn(1)-sdr(1)*spn(3) )/2. 111 | rot(3,i)=( sdr(1)*spn(2)-sdr(2)*spn(1) )/2. 112 | 113 | END DO 114 | 115 | END SUBROUTINE BTMATRX 116 | 117 | !***********************************************************************! 118 | ! ! 119 | ! SUBROUTINE ECHROT( a, aug, r, dp1, dph, dp2) ! 120 | ! P. Bate 1987 ! 121 | !-----------------------------------------------------------------------! 122 | ! Routine to give the rate of change of Euler angles of an ! 123 | ! orientation as the result of a spin referred to global frame. ! 124 | !-----------------------------------------------------------------------! 125 | ! Arguments: ! 126 | ! a REAL ARRAY(3,3); Orientation matrix ! 127 | ! aug REAL ARRAY(1:3); Terms for Euler angle change ! 128 | ! r REAL ARRAY(1:3); Rigid body spins about x,y,z ! 129 | ! dp1,dph,dp2 REALs; changes of Euler angles ! 130 | !-----------------------------------------------------------------------! 131 | ! Convention: eps(1:6) e(11),e(22),e(33),e(12),e(23),e(31) ! 132 | ! rtn(1:3) 23,31,12 (anticlock. about x,y,z) ! 133 | ! ! 134 | !-----------------------------------------------------------------------! 135 | ! ! 136 | !***********************************************************************! 137 | SUBROUTINE ECHROT( a, aug, r, dp1, dph, dp2) 138 | 139 | USE FAS_CPL 140 | 141 | IMPLICIT NONE 142 | 143 | REAL(4) a, aug, r, dp1, dph, dp2 144 | REAL(4) rtn,rx,small 145 | 146 | DIMENSION a( 1:3, 1:3), aug( 1:3), r( 1:3) 147 | DIMENSION rtn( 1:3), rx( 1:3) 148 | 149 | 150 | DATA small/ 1.e-5/ 151 | 152 | rtn= MATMUL( rot(1:3,1:nss(mat_code)), gam(1:nss(mat_code))) ! spin due to slip 153 | rtn= rtn - r ! subtract deformation r-b spin 154 | rx= MATMUL( a, rtn) ! transform to crystal values 155 | 156 | !---------------------------Euler angle rates with 'gimbal lock' to Ph1 157 | IF ( ABS( aug(3) ) .LT. small) THEN 158 | dp1=rtn(3) 159 | ELSE 160 | dp1=( aug(1)*rx(1) + aug(2)*rx(2) )/aug(3) 161 | ENDIF 162 | 163 | dph= aug(2)*rx(1) - aug(1)*rx(2) 164 | dp2= rx(3) - dp1*a(3,3) 165 | 166 | 167 | END SUBROUTINE ECHROT 168 | 169 | -------------------------------------------------------------------------------- /src/fasolt/ela-plas.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! SUBROUTINE ELAST( jgp, el_comp) ! 4 | !-----------------------------------------------------------------------! 5 | ! Routine to give elastic constants (compliance matrix, current axes) ! 6 | !-----------------------------------------------------------------------! 7 | ! Arguments: jgp INTEGER; gauss point number ! 8 | ! el_comp REAL(6,6); compliance matrix ! 9 | !-----------------------------------------------------------------------! 10 | ! ! 11 | !***********************************************************************! 12 | SUBROUTINE ELASTC( jgp, el_comp) 13 | 14 | USE FAS_COM ! FASOLT main variables declaration 15 | USE FAS_CPL ! Crystal plasticity variables 16 | 17 | 18 | IMPLICIT NONE 19 | INTEGER(4) jgp, iset, jset, i, j, k, l 20 | REAL(4) ph1, phi, ph2, a, aug, mult, term1, term2, term3 21 | REAL(4), DIMENSION(1:6, 1:6):: el_comp 22 | DIMENSION a(1:3, 1:3), aug(1:3) 23 | 24 | !----------------------------------------------------------current orientation matrix 25 | ph1= sv(1,jgp) + dsv(1,jgp) 26 | phi= sv(2,jgp) + dsv(2,jgp) 27 | ph2= sv(3,jgp) + dsv(3,jgp) 28 | 29 | CALL CTMATRX( ph1, phi, ph2, a, aug) 30 | a= TRANSPOSE(a) ! crystal to specimen basis 31 | 32 | !-----------------------loop on reduced tensor terms, expand and calculate compliance 33 | 34 | DO iset=1,6 35 | SELECT CASE(iset) 36 | CASE(1,2,3) 37 | i=iset 38 | j=iset 39 | mult=1. ! multiplier unity if no shear involved 40 | CASE(4,5,6) 41 | i=1+MOD(iset-3,3) 42 | j=1+MOD(i,3) 43 | mult=2. ! double if shear involved ( tensor to 'engineering') 44 | END SELECT 45 | 46 | DO jset=iset,6 47 | SELECT CASE(jset) 48 | CASE(1,2,3) 49 | k=jset 50 | l=jset 51 | CASE(4,5,6) 52 | k=1+MOD(jset-3,3) 53 | l=1+MOD(k,3) 54 | END SELECT 55 | 56 | term1= a(i,1)*a(j,1)*a(k,1)*a(l,1)*e(1,mat_code) & 57 | & +a(i,2)*a(j,2)*a(k,2)*a(l,2)*e(2,mat_code) & 58 | & +a(i,3)*a(j,3)*a(k,3)*a(l,3)*e(3,mat_code) 59 | 60 | term2= a(i,2)*a(j,2)*a(k,3)*a(l,3)*e(4,mat_code) & 61 | & +a(i,3)*a(j,3)*a(k,2)*a(l,2)*e(4,mat_code) & 62 | & +a(i,3)*a(j,3)*a(k,1)*a(l,1)*e(5,mat_code) & 63 | & +a(i,1)*a(j,1)*a(k,3)*a(l,3)*e(5,mat_code) & 64 | & +a(i,1)*a(j,1)*a(k,2)*a(l,2)*e(6,mat_code) & 65 | & +a(i,2)*a(j,2)*a(k,1)*a(l,1)*e(6,mat_code) 66 | 67 | term3= a(i,2)*a(j,3)*a(k,2)*a(l,3)*e(7,mat_code) & 68 | & +a(i,3)*a(j,2)*a(k,3)*a(l,2)*e(7,mat_code) & 69 | & +a(i,3)*a(j,1)*a(k,3)*a(l,1)*e(8,mat_code) & 70 | & +a(i,1)*a(j,3)*a(k,1)*a(l,3)*e(8,mat_code) & 71 | & +a(i,1)*a(j,2)*a(k,1)*a(l,2)*e(9,mat_code) & 72 | & +a(i,2)*a(j,1)*a(k,2)*a(l,1)*e(9,mat_code) 73 | 74 | el_comp(iset,jset)= mult*(term1 + term2 + 0.5*term3) 75 | END DO 76 | END DO 77 | 78 | !----------------------------------------------------------complete symmetric matrix 79 | DO iset=1,5 80 | DO jset= iset+1,6 81 | el_comp(jset,iset)= el_comp(iset,jset) 82 | END DO 83 | END DO 84 | 85 | 86 | END SUBROUTINE ELASTC 87 | 88 | !***********************************************************************! 89 | ! ! 90 | ! SUBROUTINE PLASTC( dt, am) ! 91 | !-----------------------------------------------------------------------! 92 | ! Routine to give the slip system resistances and the matrix of ! 93 | ! derivatives of (log)slip resistance WRT slip strain increment. ! 94 | ! Note that the hardening rate is calculated at the current value ! 95 | ! of slip resistance i.e. including effect of slip increments given ! 96 | !-----------------------------------------------------------------------! 97 | ! ARGUMENTS: dt REAL; Time step ! 98 | ! am REAL; Strain rate sensitivity index ! 99 | ! matrix dlnS0/dDgamma ! 100 | !-----------------------------------------------------------------------! 101 | ! Model Parameters: ! 102 | ! ampar(1) m slip rate sensitivity ! 103 | ! ampar(2) theta0 (ds/de at zero stress -thetaIV) ! 104 | ! ampar(3) thetaIV ( stage IV hardening ! 105 | ! ampar(4) alpha index ! 106 | ! ampar(5) tauSS(rate=1) ! 107 | ! ampar(6) n saturation rate sensitivity ! 108 | ! ! 109 | !***********************************************************************! 110 | SUBROUTINE PLASTC( dt, am) 111 | 112 | USE FAS_COM ! FASOLT main variables declaration 113 | USE FAS_CPL 114 | 115 | IMPLICIT NONE 116 | 117 | REAL(4) dt 118 | 119 | INTEGER(4) i, j, iss, jss, ns 120 | REAL(4) THETA, sumss, sterm, arg, sst_iso, sst, ah_1, sums_w, gam_sign, tiny 121 | 122 | INTEGER(4), DIMENSION(1:nss(mat_code)):: iactiv 123 | REAL(4), DIMENSION(1:nss(mat_code)):: am, grad_h 124 | REAL(4), DIMENSION(1:nss(mat_code),1:nss(mat_code)):: gradient 125 | 126 | !---------------------statement function for theta 127 | THETA(i,arg)= ampar(3,i,mat_code) + & 128 | & ampar(2,i,mat_code)*SIGN(ABS(arg)**ampar(4,i,mat_code),arg) 129 | 130 | 131 | !----------------------------------------local control variables 132 | DATA tiny/ 1.e-14 / 133 | 134 | am(1:nss(mat_code))=ampar(1,1:nss(mat_code),mat_code) 135 | 136 | !------------------------------------flag list of active sysytems 137 | ns= nss(mat_code) 138 | 139 | DO iss= 1, ns 140 | iactiv(iss)= 0 141 | END DO 142 | 143 | DO i= 1, nsa 144 | iss= isa(i) 145 | iactiv(iss)= i 146 | END DO 147 | 148 | !---------------------------------------accumulated slip increment 149 | sumss= 0. 150 | DO iss= 1, ns 151 | sumss= sumss+ ABS(gam(iss)) 152 | END DO 153 | 154 | !-------------------------------------------loop on ALL systems 155 | DO iss=1, ns 156 | !-------------------------------------rate sensitive target stress 157 | sst= ampar(5,iss,mat_code)*(sumss/dt)**ampar(6,iss,mat_code) 158 | 159 | !-----------------------------------------------current theta 160 | if(sst .ne. 0.) then 161 | arg= 1. - ((s0(iss))/sst) 162 | else 163 | arg = 0. 164 | end if 165 | 166 | IF (arg .LT. 0.) arg=0. 167 | 168 | ah_1= THETA(iss,arg) 169 | grad_h(iss)= ah_1 170 | END DO 171 | 172 | !-------------------------------------------------full hardening matrix 173 | DO i= 1, ns 174 | gradient(1:ns,i)= smatrx(1:ns,i,mat_code)*grad_h(i) 175 | END DO 176 | 177 | !--------------------------------------------------slip resistances 178 | DO iss= 1, ns 179 | s1(iss)= s0(iss) 180 | DO jss=1,ns 181 | s1(iss)= s1(iss)+ gradient(iss,jss)*ABS(gam(jss)) 182 | END DO 183 | END DO 184 | 185 | !----------------------------actives only for log. hardening matrix 186 | DO i=1, nsa 187 | iss=isa(i) 188 | DO j= 1, nsa 189 | jss=isa(j) 190 | 191 | IF (ABS(gam(jss)) .GT. tiny) THEN 192 | gam_sign= gam(jss)/ABS(gam(jss)) 193 | ah(i,j)= gam_sign* gradient(iss,jss)/s1(iss) 194 | ELSE 195 | ah(i,j)= 0. 196 | ENDIF 197 | 198 | END DO 199 | END DO 200 | 201 | END SUBROUTINE !PLASTC 202 | 203 | 204 | !-----------------individual system target(depends on latent matrix) 205 | ! sums_w= 0. 206 | ! DO jss= 1, nss(mat_code) 207 | ! sums_w= sums_w + smatrx(iss,jss,mat_code)*ABS(gam(jss)) 208 | ! END DO 209 | ! sst= sst_iso*(1. + sums_w/sumss) 210 | 211 | !-----------------------------------------------current theta (RK4) 212 | ! arg= 1. - ((s0(iss) )/sst) ;IF (arg .LT. 0.) arg=0. 213 | ! ah_1= THETA(iss,arg) 214 | 215 | ! arg= 1. - ((s0(iss)+0.5*ah_1*sumss)/sst) ;IF (arg .LT. 0.) arg=0. 216 | ! ah_2= THETA(iss,arg) 217 | 218 | ! arg= 1. - ((s0(iss)+0.5*ah_2*sumss)/sst) ;IF (arg .LT. 0.) arg=0. 219 | ! ah_3= THETA(iss,arg) 220 | 221 | ! arg= 1. - ((s0(iss)+ ah_3*sumss)/sst) ;IF (arg .LT. 0.) arg=0. 222 | ! ah_4= THETA(iss,arg) 223 | 224 | ! grad_h(iss)= (ah_1 + 2.*ah_2 + 2.*ah_3 + ah_4) /6. 225 | 226 | 227 | -------------------------------------------------------------------------------- /src/fasolt/fas-com-mod.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************************! 2 | ! ! 3 | ! MODULE FAS_COM ! 4 | !-----------------------------------------------------------------------------------! 5 | ! Module containing the type and array declarations for the main FASOLT variables ! 6 | !-----------------------------------------------------------------------------------! 7 | ! ! 8 | !***********************************************************************************! 9 | MODULE FAS_COM 10 | 11 | IMPLICIT NONE 12 | 13 | INTEGER, PARAMETER:: maxnod= 65000, maxdof= 180000, maxels= 8100 14 | INTEGER, PARAMETER:: maxgps= 65000, maxinc= 10000, maxsvs= 63 15 | INTEGER, PARAMETER:: maxofd= 1000 16 | 17 | INTEGER(4) nlmnt, nnod, ngps, ninc, ninc0, ninc1, nsv, inc, nxs, nfs, maxit, tflag 18 | 19 | INTEGER(4), DIMENSION( 1:maxels) :: le, lt, nd, np 20 | INTEGER(4), DIMENSION( 1:20, 1:maxels) :: ln 21 | INTEGER(4), DIMENSION( 1:8, 1:maxels) :: lg 22 | INTEGER(4), DIMENSION( 1:maxnod) :: ib 23 | REAL(4), DIMENSION( 1:maxdof) :: x, dx, fc, ddx 24 | REAL(4), DIMENSION( 1:maxgps) :: eps, dep 25 | REAL(4), DIMENSION( 1:6, 1:maxgps) :: st, ep, ds, de 26 | REAL(4), DIMENSION( 1:3, 1:maxgps) :: rt, dr 27 | REAL(4), DIMENSION( 1:maxsvs, 1:maxgps) :: sv, dsv 28 | 29 | REAL(4), DIMENSION( 1:maxinc) :: tiem 30 | REAL(4), DIMENSION( 1:15, 1:99, 1:maxinc) :: x_spec 31 | REAL(4), DIMENSION( 1: 3, 1:99, 1:maxinc) :: f_spec 32 | 33 | INTEGER(4), DIMENSION( 1: maxofd, 1:maxdof) :: is 34 | REAL(4), DIMENSION( 1: maxofd, 1:maxdof) :: ss 35 | 36 | !-------------------------------------surface data 37 | REAL(4) amu, anu, aga 38 | 39 | !-------------------------------------numerical control data 40 | REAL(4) toler, alpha, efix, smalp, smalf, smald, smale, smalr, afactor 41 | 42 | 43 | END MODULE FAS_COM 44 | 45 | !***********************************************************************************! 46 | ! ! 47 | ! MODULE FAS_CPL ! 48 | !-----------------------------------------------------------------------------------! 49 | ! Module containing type and array declarations for crystal ! 50 | ! plasticity variables and material property data ! 51 | !-----------------------------------------------------------------------------------! 52 | ! ! 53 | !***********************************************************************************! 54 | MODULE FAS_CPL 55 | 56 | IMPLICIT NONE 57 | INTEGER(4), PARAMETER :: maxss=60, maxmds= 12, mgps=65000 ! this is the same as maxgps, only did this to avoid conflict 58 | 59 | INTEGER(4) nmpar, nmatl, mat_code, nsa, twinlim 60 | REAL(4) twinprob 61 | 62 | INTEGER(4), DIMENSION( 1:maxss) :: isa 63 | REAL(4), DIMENSION( 1:maxss) :: tau, gam, wks, s0, s1 64 | REAL(4), DIMENSION( 1:6, 1:maxss) :: b ! slip rate to strain rate matrix 65 | REAL(4), DIMENSION( 1:3, 1:maxss) :: rot ! slip rate to global spin 66 | REAL(4), DIMENSION( 1:maxss, 1:maxss):: ah 67 | 68 | INTEGER(4), DIMENSION( 1: maxmds):: nss 69 | REAL(4), DIMENSION( 1:3, 1:maxss, maxmds):: ab, an ! slip direction and slip plane normal vector components 70 | REAL(4), DIMENSION( 1:maxss, 1:maxss , maxmds):: smatrx 71 | 72 | REAL(4), DIMENSION( 1:9, 1:maxmds):: e 73 | INTEGER(4), DIMENSION(1:mgps):: timestwinned ! number of times IP has twinned 74 | INTEGER(4), DIMENSION(1:mgps):: twinsys ! indicate system for twinning 75 | REAL(4), DIMENSION( 1:maxss, 1:maxmds):: ssang ! angle of reorientation for twin system (0. if slip) 76 | REAL(4), DIMENSION(1:maxss, 1:mgps):: srate ! slip rates to be written to .slp file 77 | REAL(4), DIMENSION(1:maxss, 1:mgps):: cumslip ! cumulative slip activity to be written to .slp file 78 | REAL(4), DIMENSION(1:10, 1:maxss, 1:maxmds):: ampar 79 | 80 | END MODULE FAS_CPL 81 | -------------------------------------------------------------------------------- /src/fasolt/makefile: -------------------------------------------------------------------------------- 1 | objects=fas-com-mod.o Bconds.o Cpstrs.o Elvals.o \ 2 | Faslt_io_nowin.o Fasolt3.o Shapef.o Sig_eps.o \ 3 | Stif_sol.o crys-cons.o crys_math.o ela-plas.o 4 | 5 | #ifeq(machine,'i486') 6 | #FC=ifort -i-static -g -fpe0 -traceback 7 | #FC=ifort -i-static -O3 -p -g 8 | FC=ifort -i-static -O3 9 | #endif 10 | #LIBS=-L/opt/intel/fce/9.1.036/lib/libimf.so 11 | 12 | %.o : %.f90 13 | $(FC) -c $(FFLAGS) $< -o $@ 14 | 15 | fasolt3:$(objects) 16 | $(FC) -o fasolt3 $(objects) 17 | 18 | fasolt3.o:fasolt.f90 19 | 20 | Bconds.o:Bconds.f90 21 | 22 | Cpstrs.o:Cpstrs.f90 23 | 24 | Elvals.o:Elvals.f90 25 | 26 | Shapef.o:Shapef.f90 27 | 28 | Sig_eps.o:Sig_eps.f90 29 | 30 | Stif_sol.o:Stif_sol.f90 31 | 32 | crys-cons.o:crys-cons.f90 33 | 34 | crys_math.o:crys_math.f90 35 | 36 | ela_plas.o:ela_plas.f90 37 | 38 | Faslt-io_nowin.o:Faslt-io_nowin.f90 39 | 40 | fas_com_mod.o:fas_com_mod.f90 41 | 42 | .PHONY:clean 43 | clean: 44 | rm fasolt3 $(objects) fas_com.mod 45 | 46 | install: 47 | cp fasolt3 /Users/joao/bin/ 48 | -------------------------------------------------------------------------------- /src/prepro/crysdat.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************! 2 | ! ! 3 | ! Block data CRYSDAT: slip system geometry and interaction definitions ! 4 | ! ! 5 | !***********************************************************************! 6 | 7 | BLOCK DATA CRYSDAT 8 | 9 | IMPLICIT NONE 10 | 11 | INTEGER(4) i,j 12 | !---------------------------------Slip systems and interaction values 13 | INTEGER(4) nss 14 | REAL(4) ab, an, smatrx 15 | COMMON/ slpsys/ nss, ab( 1:3, 1:60), an( 1:3, 1:60), smatrx( 1:60, 1:60) 16 | 17 | ! Data for slip direction (ab) and slip plane normal (an) vectors for 18 | ! FCC octahedral slip. Order is a1,a2,a3.......d3 in Bishops notation 19 | 20 | DATA nss /12/ 21 | 22 | DATA ((ab(i,j),i=1,3),j=1,12)/ 0.000000, 0.707107,-0.707107, & 23 | & -0.707107, 0.000000, 0.707107, 0.707107,-0.707107, 0.000000, & 24 | & 0.000000, 0.707107, 0.707107,-0.707107, 0.000000,-0.707107, & 25 | & 0.707107,-0.707107, 0.000000, 0.000000, 0.707107,-0.707107, & 26 | & 0.707107, 0.000000, 0.707107,-0.707107,-0.707107, 0.000000, & 27 | & 0.000000,-0.707107,-0.707107,-0.707107, 0.000000, 0.707107, & 28 | & 0.707107, 0.707107, 0.000000 / 29 | DATA ((an(i,j),i=1,3),j=1,12)/ 0.577350, 0.577350, 0.577350, & 30 | & 0.577350, 0.577350, 0.577350, 0.577350, 0.577350, 0.577350, & 31 | & 0.577350, 0.577350,-0.577350, 0.577350, 0.577350,-0.577350, & 32 | & 0.577350, 0.577350,-0.577350,-0.577350, 0.577350, 0.577350, & 33 | & -0.577350, 0.577350, 0.577350,-0.577350, 0.577350, 0.577350, & 34 | & 0.577350,-0.577350, 0.577350, 0.577350,-0.577350, 0.577350, & 35 | & 0.577350,-0.577350, 0.577350/ 36 | 37 | 38 | !********************** set for bcc, ab and an swapped 39 | 40 | ! DATA ((an(i,j),i=1,3),j=1,12)/ 0.000000, 0.707107,-0.707107, & 41 | ! & -0.707107, 0.000000, 0.707107, 0.707107,-0.707107, 0.000000, & 42 | ! & 0.000000, 0.707107, 0.707107,-0.707107, 0.000000,-0.707107, & 43 | ! & 0.707107,-0.707107, 0.000000, 0.000000, 0.707107,-0.707107, & 44 | ! & 0.707107, 0.000000, 0.707107,-0.707107,-0.707107, 0.000000, & 45 | ! & 0.000000,-0.707107,-0.707107,-0.707107, 0.000000, 0.707107, & 46 | ! & 0.707107, 0.707107, 0.000000 / 47 | ! DATA ((ab(i,j),i=1,3),j=1,12)/ 0.577350, 0.577350, 0.577350, & 48 | ! & 0.577350, 0.577350, 0.577350, 0.577350, 0.577350, 0.577350, & 49 | ! & 0.577350, 0.577350,-0.577350, 0.577350, 0.577350,-0.577350, & 50 | ! & 0.577350, 0.577350,-0.577350,-0.577350, 0.577350, 0.577350, & 51 | ! & -0.577350, 0.577350, 0.577350,-0.577350, 0.577350, 0.577350, & 52 | ! & 0.577350,-0.577350, 0.577350, 0.577350,-0.577350, 0.577350, & 53 | ! & 0.577350,-0.577350, 0.577350/ 54 | 55 | ! Data for interaction matrix, (isotropic hardening) 56 | ! DATA ((smatrx(i,j),i=1,12),j=1,12)/ 144*./ 57 | 58 | ! data for interaction matrix (simple latent) 59 | DATA (smatrx(i, 1),i=1,12)/ 0.,11*1./ 60 | DATA (smatrx(i, 2),i=1,12)/ 1.,0.,10*1./ 61 | DATA (smatrx(i, 3),i=1,12)/ 2*1.,0., 9*1./ 62 | DATA (smatrx(i, 4),i=1,12)/ 3*1.,0., 8*1./ 63 | DATA (smatrx(i, 5),i=1,12)/ 4*1.,0., 7*1./ 64 | DATA (smatrx(i, 6),i=1,12)/ 5*1.,0., 6*1./ 65 | DATA (smatrx(i, 7),i=1,12)/ 6*1.,0., 5*1./ 66 | DATA (smatrx(i, 8),i=1,12)/ 7*1.,0., 4*1./ 67 | DATA (smatrx(i, 9),i=1,12)/ 8*1.,0., 3*1./ 68 | DATA (smatrx(i,10),i=1,12)/ 9*1.,0., 2*1./ 69 | DATA (smatrx(i,11),i=1,12)/10*1.,0., 1./ 70 | DATA (smatrx(i,12),i=1,12)/11*1.,0. / 71 | 72 | END BLOCK DATA CRYSDAT 73 | -------------------------------------------------------------------------------- /src/prepro/fas_com_mod.f90: -------------------------------------------------------------------------------- 1 | !***********************************************************************************! 2 | ! ! 3 | ! MODULE FAS_COM ! 4 | !-----------------------------------------------------------------------------------! 5 | ! Module containing the type and array declarations for the main FASOLT variables ! 6 | !-----------------------------------------------------------------------------------! 7 | ! maxnod = maximum number of nodes (at least 8*maxels) ! 8 | ! maxels = maximum number of elements ! 9 | ! maxgps = maximum number of gauss points (st least 8*maxels) ! 10 | ! maxinc = maximum number of increments ! 11 | ! maxsvs = maximum number saved variables ! 12 | ! maxdof = ? ! 13 | ! ! 14 | !***********************************************************************************! 15 | MODULE FAS_COM 16 | 17 | !INTEGER, PARAMETER:: maxnod= 50000, maxdof=150000, maxels= 6000 18 | INTEGER, PARAMETER:: maxnod= 65000, maxdof= 200000, maxels= 8500 19 | INTEGER, PARAMETER:: maxgps= 65000, maxinc= 10000, maxsvs= 63 20 | 21 | 22 | INTEGER(4) nlmnt, nnod, ngps, ninc, ninc0, ninc1, nsv, inc, nxs, nfs, maxit 23 | 24 | INTEGER(4), DIMENSION( 1:maxels) :: le, lt, nd, np 25 | INTEGER(4), DIMENSION( 1:20, 1:maxels) :: ln 26 | INTEGER(4), DIMENSION( 1:8, 1:maxels) :: lg 27 | INTEGER(4), DIMENSION( 1:maxnod) :: ib 28 | REAL(4), DIMENSION( 1:maxdof) :: x, dx, fc, ddx 29 | REAL(4), DIMENSION( 1:maxgps) :: eps, dep 30 | REAL(4), DIMENSION( 1:6, 1:maxgps) :: st, ep, ds, de 31 | REAL(4), DIMENSION( 1:3, 1:maxgps) :: rt, dr 32 | REAL(4), DIMENSION( 1:maxsvs, 1:maxgps) :: sv, dsv 33 | 34 | REAL(4), DIMENSION( 1:maxinc) :: tiem 35 | REAL(4), DIMENSION( 1:15, 1:99, 1:maxinc) :: x_spec 36 | REAL(4), DIMENSION( 1:3, 1:99, 1:maxinc) :: f_spec 37 | 38 | !------------------------------------------------------------Material data 39 | INTEGER(4), PARAMETER :: maxss=60, maxmds= 12 40 | 41 | INTEGER(4) nmpar, nmatl, mat_code, twinlim 42 | REAL(4) twinprob 43 | 44 | INTEGER(4), DIMENSION( 1:maxss) :: isa 45 | REAL(4), DIMENSION( 1:maxss) :: tau, gam, wks, s0, s1 46 | REAL(4), DIMENSION( 1:6, 1:maxss) :: b 47 | REAL(4), DIMENSION( 1:3, 1:maxss) :: rot 48 | REAL(4), DIMENSION( 1:maxss, 1:maxss):: ah 49 | 50 | INTEGER(4), DIMENSION( 1: maxmds):: nss 51 | REAL(4), DIMENSION( 1:3, 1:maxss, maxmds):: ab, an 52 | REAL(4), DIMENSION( 1:maxss, 1:maxss , maxmds):: smatrx 53 | 54 | REAL(4), DIMENSION( 1:9, 1:maxmds):: e 55 | REAL(4), DIMENSION( 1:maxss, 1:maxmds):: ssang 56 | REAL(4), DIMENSION(1:10, 1:maxss, 1:maxmds):: ampar 57 | 58 | !--------------------------------------surface data 59 | REAL(4) amu, anu, aga 60 | 61 | 62 | END MODULE FAS_COM 63 | -------------------------------------------------------------------------------- /src/prepro/fs2-xtal.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE PERTID ! 4 | ! Perturbation of ideal orientation ! 5 | ! ! 6 | !*******************************************************************************! 7 | SUBROUTINE PERTID( ph1, phi, ph2, chi, r1, r2, r3 ) 8 | 9 | ! USE DFLIB 10 | 11 | IMPLICIT NONE 12 | REAL(4) ph1, phi, ph2, chi, r1, r2, r3, a, b 13 | DIMENSION a(1:3, 1:3), b( 1:3, 1:3) 14 | 15 | !----------------------------------------ideal and perturbation matrices 16 | CALL EUATOA( ph1, phi, ph2, a) 17 | 18 | CALL RANDOM_NUMBER(r1) 19 | CALL RANDOM_NUMBER(r2) 20 | CALL RANDOM_NUMBER(r3) 21 | r1= ACOS( 2.*r1 -1.) 22 | r2= 6.28318530718 *r2 23 | r3= chi*r3 24 | CALL AXATOA( r3, r1, r2, b) 25 | 26 | !--------------------------------------------------multiply, get angles 27 | a= MATMUL(a,b) 28 | 29 | 30 | IF ( ABS (a(3,3)) .GE. 1.) then 31 | r1= ATAN2( a(1,2), a(1,1) )/2. 32 | r2= 0. 33 | r3= r1 34 | ELSE 35 | r1= ATAN2( a(3,1), -a(3,2) ) 36 | r2= ACOS( a(3,3) ) 37 | r3= ATAN2( a(1,3), a(2,3) ) 38 | END IF 39 | 40 | END SUBROUTINE 41 | 42 | !***************************************************************************! 43 | ! ! 44 | ! SUBROUTINE EUATOA(ph1,phi,ph2,a) ! 45 | !---------------------------------------------------------------------------! 46 | ! Orientation matrix, a, from Euler angles ph1, phi, ph2(in radians) ! 47 | ! with Bunge's definition ( all anticlockwise, about current z, x, z). ! 48 | ! Matrix has crystal definition of specimen axes as columns. ! 49 | ! ! 50 | !***************************************************************************! 51 | SUBROUTINE EUATOA( ph1, phi, ph2, a) 52 | 53 | IMPLICIT NONE 54 | 55 | REAL(4) ph1, phi, ph2, a 56 | REAL(4) c, s, c1, c2,s1, s2, c1c2, c1s2, s1c2, s1s2 57 | 58 | DIMENSION a(1:3,1:3) 59 | 60 | !-----------------------------Form trig function terms 61 | c1= COS(ph1) 62 | s1= SIN(ph1) 63 | c2= COS(ph2) 64 | s2= SIN(ph2) 65 | c= COS(phi) 66 | s= SIN(phi) 67 | c1c2=c1*c2 68 | s1s2=s1*s2 69 | c1s2=c1*s2 70 | s1c2=s1*c2 71 | 72 | !---------------------------Form the transform matrix 73 | a(1,1)= c1c2 - s1s2*c 74 | a(2,1)=-c1s2 - s1c2*c 75 | a(3,1)= s1*s 76 | a(1,2)= s1c2 + c1s2*c 77 | a(2,2)=-s1s2 + c1c2*c 78 | a(3,2)=-c1*s 79 | a(1,3)= s2*s 80 | a(2,3)= c2*s 81 | a(3,3)= c 82 | 83 | 84 | END SUBROUTINE EUATOA 85 | 86 | !***************************************************************************! 87 | ! ! 88 | ! SUBROUTINE AXATOA( omega, theta, psi, a) ! 89 | !---------------------------------------------------------------------------! 90 | ! Routine to calculate the orientation matrix, a, from axis/angle measure ! 91 | ! with angle omega, about the axis with polar angle theta and azimuthal ! 92 | ! angle psi. All angles in radians. ! 93 | ! Matrix has crystal definition of specimen axes as columns. ! 94 | ! ! 95 | !***************************************************************************! 96 | SUBROUTINE AXATOA(omega,theta,psi,a) 97 | 98 | IMPLICIT NONE 99 | 100 | INTEGER(4) i, j, k 101 | REAL(4) omega, theta, psi, a, d, st, cw, sw 102 | 103 | DIMENSION a(1:3,1:3), d(3) 104 | 105 | !-------------------------------------------Rotation axis 106 | st= SIN(theta) 107 | d(1)= COS(psi)*st 108 | d(2)= SIN(psi)*st 109 | d(3)= COS(theta) 110 | 111 | !-------------------------------Form matrix in three stages 112 | cw=COS(omega) 113 | sw=SIN(omega) 114 | 115 | a= 0. 116 | 117 | DO i= 1, 3 118 | a(i,i)= cw 119 | DO J= 1, 3 120 | a(i,j)= a(i,j) + (1.-cw)*d(i)*d(j) 121 | END DO 122 | 123 | j= 1 + MOD(i,3) 124 | k= 1 + MOD(j,3) 125 | a(j,k)=a(j,k)-sw*d(i) 126 | a(k,j)=a(k,j)+sw*d(i) 127 | 128 | END DO 129 | 130 | END SUBROUTINE AXATOA 131 | -------------------------------------------------------------------------------- /src/prepro/fs3p-bkc.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE SETBOUNDS ! 4 | ! Simple brick boundary condition setting ! 5 | !-------------------------------------------------------------------------------! 6 | ! 7 | ! ! 8 | !*******************************************************************************! 9 | SUBROUTINE SETBOUNDS(tolerance, xfree) 10 | 11 | USE FAS_COM 12 | 13 | IMPLICIT NONE 14 | 15 | INTEGER(4) i, j, k, l_side, xfree 16 | REAL(4) tolerance, xtreme 17 | DIMENSION xtreme( 1:3, 1:2) 18 | 19 | !-------------------------------------------------------------brick extreme coordinates 20 | xtreme(1:3,1)=x(1:3) 21 | xtreme(1:3,2)=x(1:3) 22 | 23 | DO i= 2, nnod 24 | DO j= 1, 3 25 | k= 3*i -3 +j 26 | IF ( x(k) .LT. xtreme(j,1) ) xtreme(j,1)=x(k) 27 | IF ( x(k) .GT. xtreme(j,2) ) xtreme(j,2)=x(k) 28 | END DO 29 | END DO 30 | 31 | !-------------------------------------------------------------set BC codes on each node 32 | DO i= 1, nnod 33 | 34 | 35 | !----------------------------------------------determine if at brick surface 36 | l_side= 0 37 | DO j= 1, 3 38 | k=3*i -3 +j 39 | 40 | IF( ABS(x(k)-xtreme(j,1)) .LT. tolerance ) l_side= l_side + 2**( 2*j-2) 41 | IF( ABS(x(k)-xtreme(j,2)) .LT. tolerance ) l_side= l_side + 2**( 2*j-1) 42 | 43 | END DO 44 | 45 | IF ( l_side .GT. 0 ) THEN 46 | 47 | !-----------------------------absolute displacements 'full' specifications as defaults 48 | SELECT CASE( l_side) 49 | 50 | CASE( 1) ! x fixed (x min) 51 | ib(i)= 100 52 | CASE( 4) ! y fixed (y min) 53 | ib(i)= 200 54 | CASE(16) ! z fixed (z min) 55 | ib(i)= 300 56 | CASE( 5) ! x fix, y fix (x min, y min) 57 | ib(i)= 400 58 | CASE(17) ! x fix, z fix (x min, z min) 59 | ib(i)= 500 60 | CASE(20) ! y fix, z fix (y min, z min) 61 | ib(i)= 600 62 | CASE(21) ! all fixed (x min, y min, z min) 63 | ib(i)= 700 64 | 65 | CASE( 2) ! x spec. (x max) 66 | ib(i)= 800 67 | CASE( 8) ! y spec. (y max) 68 | ib(i)= 900 69 | CASE(32) ! z spec. (z max) 70 | ib(i)=1000 71 | CASE(10) ! x, y spec. (x max, y max) 72 | ib(i)=1100 73 | CASE(34) ! x, z spec. (x max, z max) 74 | ib(i)=1200 75 | CASE(40) ! y, z spec. (y max, z max) 76 | ib(i)=1300 77 | CASE(42) ! x, y, z spec. (x max, y max, z max) 78 | ib(i)=1400 79 | 80 | CASE( 9) ! x fix, y spec. (x min, y max) 81 | ib(i)=1500 82 | CASE(33) ! x fix, z spec. (x min, z max) 83 | ib(i)=1600 84 | CASE( 6) ! y fix, x spec. (y min, x max) 85 | ib(i)=1700 86 | CASE(36) ! y fix, z spec. (y min, z max) 87 | ib(i)=1800 88 | CASE(18) ! z fix, x spec. (z min, x max) 89 | ib(i)=1900 90 | CASE(24) ! z fix, y spec. (z min, y max) 91 | ib(i)=2000 92 | 93 | CASE(26) ! x, y spec., z fixed (x max, y max, z min) 94 | ib(i)=2100 95 | CASE(38) ! x, z spec., y fixed (x max, y min, z max) 96 | ib(i)=2200 97 | CASE(41) ! y, z spec., x fixed (x min, y max, z max) 98 | ib(i)=2300 99 | CASE(37) ! x, y fixed, z spec. (x min, y min, z max) 100 | ib(i)=2400 101 | CASE(25) ! x, z fixed, y spec. (x min, y max, z min) 102 | ib(i)=2500 103 | CASE(22) ! y, z fixed, x spec. (x max, y min, z min) 104 | ib(i)=2600 105 | 106 | CASE DEFAULT !free boundary (any true) 107 | ib(i)=1 108 | 109 | END SELECT 110 | 111 | !--------------------------options for relative (strain), FC, 'channel die' or 'tensile' freedoms 112 | SELECT CASE( xfree ) 113 | CASE(0) ! 'strain' condition 114 | IF ( l_side .GT. 0) THEN 115 | ib(i)= 5000 116 | END IF 117 | 118 | CASE(1) ! fully specified faces 119 | 120 | CASE(2) ! free x faces 121 | 122 | SELECT CASE (l_side) 123 | 124 | CASE( 1,2) 125 | ib(i)= 1 ! free ( x min or x max) 126 | 127 | CASE( 5,6) 128 | ib(i)= 200 ! y fixed ( x min, y min) 129 | CASE( 9,10) 130 | ib(i)= 900 ! y spec. ( x min, y max) 131 | 132 | CASE( 17,18) 133 | ib(i)= 300 ! z fixed ( x min, z min) 134 | CASE( 33,34) 135 | ib(i)=1000 ! z spec. ( x min, z max) 136 | 137 | CASE( 22) 138 | ib(i)= 600 ! y fixed, z fixed (x max, y min, z min) 139 | CASE( 25,26) 140 | ib(i)=2000 ! y spec., z fixed (x max, y max, z min) 141 | 142 | CASE( 37,38) 143 | ib(i)=1800 ! y fixed, z spec. ( x min, y min or max, z max) 144 | CASE( 41,42) 145 | ib(i)=1300 ! y spec., z spec. ( x min, y min or max, z max) 146 | 147 | END SELECT 148 | 149 | CASE(3) ! only x faces 150 | 151 | SELECT CASE (l_side) 152 | CASE(4,8,16,20,24,32,36,40) 153 | ib(i)=1 ! free ( not xmin or xmax) 154 | 155 | CASE(1,5,9,17,25,33,37,41) 156 | ib(i)=100 ! x fixed ( xmin) 157 | 158 | CASE(6,10,18,22,26,34,38,42) 159 | ib(i)=800 ! x specified ( xmax) 160 | 161 | 162 | END SELECT 163 | 164 | CASE DEFAULT 165 | 166 | END SELECT 167 | 168 | 169 | END IF 170 | 171 | END DO 172 | 173 | 174 | END SUBROUTINE 175 | 176 | !*******************************************************************************! 177 | ! ! 178 | ! SUBROUTINE SETKINC ! 179 | ! Sets the kinematic conditions ! 180 | ! ! 181 | !*******************************************************************************! 182 | SUBROUTINE SETKINC( xl, xfree) 183 | 184 | USE FAS_COM 185 | 186 | IMPLICIT NONE 187 | INTEGER(4) xfree, i, j 188 | REAL(4) xl, eps_inc_X, eps_inc_Y, eps_inc_Z, q, xcurr, ycurr, zcurr, dxs, dys, dzs 189 | 190 | DIMENSION xl(1:3) 191 | 192 | SELECT CASE (xfree) 193 | CASE(0, 1) 194 | WRITE(*,'(/,5X,''Enter size of increments (e11, e22 and e33): '',\)') 195 | READ(*,*) eps_inc_X, eps_inc_Y, eps_inc_Z 196 | 197 | CASE(2) 198 | WRITE(*,'(/,5X,''Enter size of increments (e22 and e33): '',\)') 199 | READ(*,*) eps_inc_Y, eps_inc_Z 200 | eps_inc_X = 0. 201 | 202 | CASE(3) 203 | WRITE(*,'(/,5X,''Enter size of increment (e11): '',\)') 204 | READ(*,*) eps_inc_X 205 | eps_inc_Y = 0. 206 | eps_inc_Z = 0. 207 | 208 | END SELECT 209 | 210 | WRITE(*,'(/,5X,''Enter number of increments (max. 2000): '',\)') 211 | READ(*,*) ninc1 212 | 213 | !-------------------------------------------------boundary conditions 214 | nxs=50 215 | nfs=0 216 | 217 | x_spec=0. 218 | 219 | xcurr= xl(1) 220 | ycurr= xl(2) 221 | zcurr= xl(3) 222 | 223 | do i=1,ninc1 224 | tiem(i)= SQRT(eps_inc_X**2 + eps_inc_Y**2 + eps_inc_Z**2) ! this gives mean rate approx. 1 225 | 226 | x_spec(1:6, 1,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) 227 | x_spec(1:6, 2,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 228 | x_spec(1:6, 3,i)=(/0.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 229 | x_spec(1:6, 4,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 230 | x_spec(1:6, 5,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 231 | x_spec(1:6, 6,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 232 | x_spec(1:6, 7,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 233 | 234 | x_spec(1:6, 8,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) 235 | x_spec(1:6, 9,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 236 | x_spec(1:6,10,i)=(/0.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 237 | x_spec(1:6,11,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 238 | x_spec(1:6,12,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 239 | x_spec(1:6,13,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 240 | x_spec(1:6,14,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 241 | 242 | x_spec(1:6,15,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 243 | x_spec(1:6,16,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 244 | x_spec(1:6,17,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 0.0 /) 245 | x_spec(1:6,18,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 246 | x_spec(1:6,19,i)=(/1.0, 0.0, 0.0, 0.0, 0.0, 1.0 /) 247 | x_spec(1:6,20,i)=(/0.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 248 | 249 | x_spec(1:6,21,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 250 | x_spec(1:6,22,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 251 | x_spec(1:6,23,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 252 | x_spec(1:6,24,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 253 | x_spec(1:6,25,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 254 | x_spec(1:6,26,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 255 | 256 | dxs = eps_inc_X*xcurr 257 | dys = eps_inc_Y*ycurr 258 | dzs = eps_inc_Z*zcurr 259 | 260 | xcurr= xcurr + dxs 261 | ycurr= ycurr + dys 262 | zcurr= zcurr + dzs 263 | 264 | DO j= 1, 26 265 | x_spec(7:15,j,i)= 0. 266 | END DO 267 | 268 | x_spec( 7, 8, i)= dxs 269 | x_spec( 7, 11, i)= dxs 270 | x_spec( 7, 12, i)= dxs 271 | x_spec( 7, 14, i)= dxs 272 | x_spec( 7, 17, i)= dxs 273 | x_spec( 7, 19, i)= dxs 274 | x_spec( 7, 21, i)= dxs 275 | x_spec( 7, 22, i)= dxs 276 | x_spec( 7, 26, i)= dxs 277 | 278 | x_spec(11, 9, i)= dys 279 | x_spec(11, 11, i)= dys 280 | x_spec(11, 13, i)= dys 281 | x_spec(11, 14, i)= dys 282 | x_spec(11, 15, i)= dys 283 | x_spec(11, 20, i)= dys 284 | x_spec(11, 21, i)= dys 285 | x_spec(11, 23, i)= dys 286 | x_spec(11, 25, i)= dys 287 | 288 | 289 | x_spec(15, 10, i)= dzs 290 | x_spec(15, 12, i)= dzs 291 | x_spec(15, 13, i)= dzs 292 | x_spec(15, 14, i)= dzs 293 | x_spec(15, 16, i)= dzs 294 | x_spec(15, 18, i)= dzs 295 | x_spec(15, 22, i)= dzs 296 | x_spec(15, 23, i)= dzs 297 | x_spec(15, 24, i)= dzs 298 | 299 | !-----------------------------------------full constraints specified straining 300 | x_spec(1:6,50,i)=(/1.0, 0.0, 1.0, 0.0, 0.0, 1.0 /) 301 | x_spec( 7, 50, i)= eps_inc_X 302 | x_spec( 9, 50, i)= 0. 303 | x_spec(11, 50, i)= eps_inc_Y 304 | x_spec(15, 50, i)= eps_inc_Z 305 | 306 | END DO 307 | 308 | END SUBROUTINE 309 | 310 | !*******************************************************************************! 311 | ! ! 312 | ! SUBROUTINE SETTIES ! 313 | ! Includes tie elements for periodic boundary conditions ! 314 | ! ! 315 | !*******************************************************************************! 316 | SUBROUTINE SETTIES( tolerance) 317 | 318 | USE FAS_COM 319 | 320 | IMPLICIT NONE 321 | 322 | CHARACTER(LEN=1) cdum 323 | LOGICAL(4) tie 324 | INTEGER(4) i, j, k, i1,i2,j1,j2,j3,k1,k2 325 | REAL(4) tolerance, xtreme 326 | DIMENSION tie(1:3), xtreme( 1:3, 1:2) 327 | 328 | !-------------------------------------------------get conditions 329 | WRITE(*,'(//,10X,'' Set tied node conditions '')') 330 | 331 | WRITE(*,'(12X,'' Tie x faces (y/n) '',\)') 332 | READ(*,'(A)') cdum 333 | tie(1)= cdum.EQ.'y' .OR. cdum.EQ.'Y' 334 | 335 | WRITE(*,'(12X,'' Tie y faces (y/n) '',\)') 336 | READ(*,'(A)') cdum 337 | tie(2)= cdum.EQ.'y' .OR. cdum.EQ.'Y' 338 | 339 | WRITE(*,'(12X,'' Tie z faces (y/n) '',\)') 340 | READ(*,'(A)') cdum 341 | tie(3)= cdum.EQ.'y' .OR. cdum.EQ.'Y' 342 | 343 | !---------------------------brick extreme coordinates 344 | 345 | xtreme(1:3,1)=x(1:3) 346 | xtreme(1:3,2)=x(1:3) 347 | 348 | DO i= 2, nnod 349 | DO j= 1, 3 350 | k= 3*i -3 +j 351 | IF ( x(k) .LT. xtreme(j,1) ) xtreme(j,1)=x(k) 352 | IF ( x(k) .GT. xtreme(j,2) ) xtreme(j,2)=x(k) 353 | END DO 354 | END DO 355 | 356 | !------------------------------------------set ties: first get lesser ends 357 | DO i1= 1, nnod 358 | 359 | DO j1= 1, 3 360 | k1=3*i1 -3 +j1 361 | IF (tie(j1) .AND. (ABS(x(k1)-xtreme(j1,1)) .LT. tolerance) ) THEN 362 | j2= 1 + MOD(j1,3) 363 | j3= 1 + MOD(j2,3) 364 | 365 | !-------------------------search for second ( greater) tie ends 366 | DO i2= 1, nnod 367 | k2=3*i2 -3 + j1 368 | 369 | IF ( (ABS(x(k2)-xtreme(j1,2)) .LT. tolerance) & 370 | & .AND. (ABS(x(3*i1-3+j2)-x(3*i2-3+j2)) .LT. tolerance) & 371 | & .AND. (ABS(x(3*i1-3+j3)-x(3*i2-3+j3)) .LT. tolerance) ) THEN 372 | 373 | !------------------------include tie elements (code 1x, 2y, 3z, 4yz, 5zx, 6xy) 374 | 375 | SELECT CASE (ib(i1)/100) 376 | CASE(1,2,3) 377 | nlmnt= nlmnt+1; le(nlmnt)=0; lt(nlmnt)=j1+3 378 | nd(nlmnt)=2; np(nlmnt)=0 379 | ln(1,nlmnt)=i1; ln(2,nlmnt)=i2 380 | 381 | CASE(6,18,20) 382 | nlmnt= nlmnt+1; le(nlmnt)=0; lt(nlmnt)= 1 383 | nd(nlmnt)=2; np(nlmnt)=0 384 | ln(1,nlmnt)=i1; ln(2,nlmnt)=i2 385 | 386 | CASE(5,16,19) 387 | nlmnt= nlmnt+1; le(nlmnt)=0; lt(nlmnt)= 2 388 | nd(nlmnt)=2; np(nlmnt)=0 389 | ln(1,nlmnt)=i1; ln(2,nlmnt)=i2 390 | 391 | CASE(4,15,17) 392 | nlmnt= nlmnt+1; le(nlmnt)=0; lt(nlmnt)= 3 393 | nd(nlmnt)=2; np(nlmnt)=0 394 | ln(1,nlmnt)=i1; ln(2,nlmnt)=i2 395 | 396 | END SELECT 397 | 398 | END IF 399 | END DO 400 | END IF 401 | END DO 402 | 403 | END DO 404 | 405 | 406 | 407 | 408 | END SUBROUTINE 409 | -------------------------------------------------------------------------------- /src/prepro/fs3p-gps.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE SETSTATE ! 4 | ! Sets the internal element state ! 5 | ! ! 6 | !*******************************************************************************! 7 | SUBROUTINE SETSTATE( nein, location) 8 | 9 | USE FAS_COM 10 | ! USE DFLIB 11 | 12 | IMPLICIT NONE 13 | LOGICAL(4) l_file 14 | INTEGER(4) nein, iselect, i, j, k, location, ilocal, set_type, nclusters, iclus 15 | REAL(4) ph1, phi, ph2, ch1, chi, ch2, r1, r2, r3, dummy 16 | DIMENSION nein(1:3), location(1:3, 1:*), ilocal(1:3) 17 | 18 | REAL(4) sumf, r 19 | REAL(4), DIMENSION(1:12):: frac 20 | 21 | 22 | INTEGER(4), ALLOCATABLE:: cluster(:) 23 | REAL(4), ALLOCATABLE:: ass_ang(:,:), ass_gps(:,:) 24 | 25 | ALLOCATE ( cluster(1:nlmnt), ass_ang(1:3, 1:nlmnt), ass_gps(1:3, 1:ngps) ) 26 | 27 | !-------------------------------------get number of slip systems 28 | WRITE(*,'(//,2X,''Enter max. no. of slip systems involved: '',\)') 29 | READ(*,*) nsv 30 | nsv= nsv + 3 31 | 32 | !------------------------------------------get type of operation 33 | WRITE(*,'(//, '' Select bicrystal (1)'',/, & 34 | & '' perturbed-ideal (2)'',/, & 35 | & '' included grain (3)'',/, & 36 | & '' file orientations (4)'',/, & 37 | & '' -or random (5): '',\)') 38 | READ(*,*) iselect 39 | 40 | SELECT CASE( iselect) 41 | 42 | CASE(1) 43 | WRITE(*,'(10X,''Enter Euler angles for bottom half: '',\)') 44 | READ(*,*) ph1,phi,ph2 45 | ph1= ph1/ 57.295779513 46 | phi= phi/ 57.295779513 47 | ph2= ph2/ 57.295779513 48 | 49 | WRITE(*,'(10X,''Enter Euler angles for top half: '',\)') 50 | READ(*,*) ch1,chi,ch2 51 | ch1= ch1/ 57.295779513 52 | chi= chi/ 57.295779513 53 | ch2= ch2/ 57.295779513 54 | 55 | CASE(2) 56 | WRITE(*,'(10X,''Enter Euler angles and chi spread: '',\)') 57 | READ(*,*) ph1,phi,ph2,chi 58 | ph1= ph1/ 57.295779513 59 | phi= phi/ 57.295779513 60 | ph2= ph2/ 57.295779513 61 | chi= chi/ 57.295779513 62 | 63 | CASE(3) 64 | WRITE(*,'(10X,''Enter Euler angles for central region: '',\)') 65 | READ(*,*) ph1,phi,ph2 66 | ph1= ph1/ 57.295779513 67 | phi= phi/ 57.295779513 68 | ph2= ph2/ 57.295779513 69 | 70 | CASE(4) 71 | WRITE(*,'(10X,''Enter number of orientation sets: '',\)') 72 | READ(*,*) nmatl 73 | 74 | CASE DEFAULT 75 | ! no i/o required 76 | 77 | END SELECT 78 | 79 | 80 | ! CALL SEED( RND$TIMESEED ) ! initialise random sequence !DIGITAL Fortran only? 81 | 82 | !--------get list of different location orientations ( for options 2, 4 & default) 83 | 84 | 85 | ! IF ( iselect.NE. 1 .AND. iselect.NE. 3 .AND. iselect.NE. 4 ) THEN 86 | IF ( iselect.NE. 1 .AND. iselect.NE. 3 ) THEN 87 | 88 | ass_ang(1,1:nlmnt)= -999. ! flag for not set 89 | set_type= -1 ! modular number for element code 90 | 91 | DO i= 1, nlmnt 92 | 93 | IF ( ass_ang(1,i) .EQ. -999.) THEN ! new 'grain' 94 | 95 | set_type= set_type + 1 ! increment type number 96 | 97 | !-------------------------------get next orientation depending on option 98 | SELECT CASE( iselect) 99 | 100 | CASE(2) ! perturbed ideal orientations 101 | CALL PERTID( ph1, phi, ph2, chi, r1, r2, r3 ) 102 | 103 | 104 | CASE DEFAULT ! random orientations 105 | CALL RANDOM_NUMBER(r1) 106 | CALL RANDOM_NUMBER(r2) 107 | CALL RANDOM_NUMBER(r3) 108 | r1= 6.2832*r1 109 | r2= ACOS(2.*r2-1.) 110 | r3= 6.2832*r3 111 | 112 | END SELECT 113 | 114 | !-----------check here and upstream for same location, set angles and code 115 | ilocal(1:3)=location(1:3,i) ! location indices for i-th element 116 | 117 | DO j= i, nlmnt 118 | IF ( ( ilocal(1) .EQ. location(1,j)) .AND. & 119 | & ( ilocal(2) .EQ. location(2,j)) .AND. & 120 | & ( ilocal(3) .EQ. location(3,j)) ) THEN 121 | ass_ang(1,j)= r1 122 | ass_ang(2,j)= r2 123 | ass_ang(3,j)= r3 124 | 125 | le(j)= 1 + set_type 126 | END IF 127 | END DO 128 | 129 | 130 | END IF 131 | END DO 132 | 133 | END IF 134 | 135 | 136 | !------------------------------------------------------Loop on elements setting orientation 137 | IF ( iselect .EQ. 4 ) THEN ! file orientations 138 | 139 | WRITE(*,'(/,15X,''Assigning orientation sets: enter fraction for: '')') 140 | DO i= 1, nmatl 141 | WRITE(*,'(18X,''set '',I3,'': '',\)') i 142 | READ(*,*) frac(i) 143 | END DO 144 | 145 | !------------------------------normalise and make cumulative 146 | sumf= SUM(frac(1:nmatl)) ; frac(1:nmatl)= frac(1:nmatl)/sumf 147 | IF ( nmatl.GT.1) THEN 148 | DO i=2, nmatl 149 | frac(i)= frac(i)+frac(i-1) 150 | END DO 151 | END IF 152 | 153 | !-----------------------------assign set to clusters (random) 154 | cluster= le ! assign element cluster number 155 | 156 | nclusters=0 157 | DO i= 1, nlmnt 158 | IF ( cluster(i) .GT. nclusters) nclusters= cluster(i) 159 | END DO 160 | 161 | DO i= 1, nclusters 162 | CALL RANDOM_NUMBER(r) 163 | k=0 164 | DO j= 1, nmatl 165 | IF ( r .GT. frac(j) ) k=j 166 | END DO 167 | 168 | DO j= 1, nlmnt 169 | IF ( cluster(j) .EQ. i ) le(j)= k+1 170 | END DO 171 | END DO 172 | 173 | 174 | ! DO i= 1, nlmnt 175 | ! CALL RANDOM_NUMBER(r) 176 | ! k=0 177 | ! DO j= 1, nmatl 178 | ! IF ( r .GT. frac(j) ) k=j 179 | ! END DO 180 | ! le(i)= k+1 181 | ! END DO 182 | 183 | DO j= 1, nmatl 184 | 185 | WRITE(*,'(25X,'' to input orientation for set'',I3,\)') j 186 | ! READ(*,*) 187 | ! CALL ORIFILE(51,l_file) 188 | 189 | ! DO i=1, nlmnt 190 | ! IF ( le(i) .EQ. j ) THEN 191 | ! IF ( cluster(i) .GT. 0 ) THEN 192 | 193 | ! READ(51,*) dummy, r1, r2, r3 194 | 195 | ! iclus= cluster(i) 196 | 197 | ! DO k= i, nlmnt 198 | ! IF ( cluster(k) .EQ. iclus ) THEN 199 | ! ass_ang(1,k)= r1 ! assign Euler angles to k-th element 200 | ! ass_ang(2,k)= r2 201 | ! ass_ang(3,k)= r3 202 | ! cluster(k)= -cluster(k) 203 | ! END IF 204 | ! END DO 205 | 206 | ! END IF 207 | ! END IF 208 | ! END DO 209 | 210 | ! DO i=1, nlmnt 211 | ! IF ( le(i) .EQ. j ) THEN 212 | ! READ(51,*) dummy, r1, r2, r3 213 | ! ass_ang(1,i)= r1 214 | ! ass_ang(2,i)= r2 215 | ! ass_ang(3,i)= r3 216 | ! END IF 217 | ! END DO 218 | 219 | CLOSE(51) 220 | 221 | ! Read orientations again, this time for every GP:--------------------------- 222 | READ(*,*) ! just a quick fix, to help read ori file twice. 223 | CALL ORIFILE(51,l_file) 224 | do i = 1, ngps 225 | READ(51,*) dummy, r1, r2, r3 226 | ass_gps(1,i)= r1 227 | ass_gps(2,i)= r2 228 | ass_gps(3,i)= r3 229 | end do 230 | CLOSE(51) 231 | ! GP-wise orientations read.------------------------------------------------- 232 | 233 | 234 | END DO 235 | 236 | ELSE 237 | 238 | DO i=1,nlmnt 239 | 240 | SELECT CASE( iselect) 241 | 242 | CASE(1) ! allocate bottom and top halves, set types 243 | IF ( location(3,i) .LE. nein(3)/2 ) THEN 244 | r1=ph1 245 | r2=phi 246 | r3=ph2 247 | le(i)= 1 248 | 249 | ELSE 250 | r1=ch1 251 | r2=chi 252 | r3=ch2 253 | le(i)= 2 254 | END IF 255 | 256 | ass_ang(1,i)= r1 257 | ass_ang(2,i)= r2 258 | ass_ang(3,i)= r3 259 | 260 | CASE(3) ! 'included' grains 261 | IF ( ( ABS( 2*location(3,i) -nein(3) -1 ).LT. nein(3)/2 ) .AND. & 262 | & ( ABS( 2*location(2,i) -nein(2) -1 ).LT. nein(2)/2 ) .AND. & 263 | & ( ABS( 2*location(1,i) -nein(1) -1 ).LT. nein(1)/2 ) ) THEN 264 | r1=ph1 265 | r2=phi 266 | r3=ph2 267 | le(i)= 1 268 | 269 | ELSE 270 | CALL RANDOM_NUMBER(r1) 271 | CALL RANDOM_NUMBER(r2) 272 | CALL RANDOM_NUMBER(r3) 273 | r1=6.2832*r1 274 | r2=acos(2.*r2-1.) 275 | r3=6.2832*r3 276 | le(i)= 2 277 | 278 | END IF 279 | 280 | ass_ang(1,i)= r1 281 | ass_ang(2,i)= r2 282 | ass_ang(3,i)= r3 283 | 284 | END SELECT 285 | END DO 286 | END IF 287 | 288 | !------------------------------------------assign orientation state variable values 289 | DO i= 1, nlmnt 290 | DO j=1,np(i) 291 | k= np(i)*(i-1) + j 292 | !sv(1,k)=ass_ang(1,i) ! assign same Euler angles to every GP inside element 293 | !sv(2,k)=ass_ang(2,i) 294 | !sv(3,k)=ass_ang(3,i) 295 | sv(1,k)=ass_gps(1,k) ! assign Euler angles from GP-wise list 296 | sv(2,k)=ass_gps(2,k) 297 | sv(3,k)=ass_gps(3,k) 298 | END DO 299 | 300 | END DO 301 | 302 | !---------------------------------------------------------null for all other states 303 | DO i=1,ngps 304 | eps(i)=0. 305 | dep(i)=0. 306 | st(1:6,i)=0. 307 | ep(1:6,i)=0. 308 | ds(1:6,i)=0. 309 | de(1:6,i)=0. 310 | rt(1:3,i)=0. 311 | dr(1:3,i)=0. 312 | END DO 313 | 314 | 315 | DEALLOCATE ( ass_ang, cluster) 316 | 317 | 318 | END SUBROUTINE 319 | -------------------------------------------------------------------------------- /src/prepro/fs3p-io_nowin.f90: -------------------------------------------------------------------------------- 1 | 2 | !***********************************************************************! 3 | ! ! 4 | ! SUBROUTINE WTDATA ! 5 | !-----------------------------------------------------------------------! 6 | ! Writes data file for FASOLT3 ! 7 | !-----------------------------------------------------------------------! 8 | ! ! 9 | !***********************************************************************! 10 | SUBROUTINE WTDATA 11 | 12 | USE FAS_COM 13 | 14 | IMPLICIT NONE 15 | 16 | LOGICAL(4) L_FILE 17 | INTEGER(4) i, j, k, i1, i2, i3 18 | 19 | INTEGER(4), PARAMETER:: IN= 51 20 | 21 | !------------------------------------common dialog to open file 22 | CALL OUTFILE( IN, L_FILE) 23 | 24 | !----------------------------------------write FAFNER data 25 | WRITE(in) ninc1 ! start increment 26 | 27 | WRITE(in) nlmnt, nnod, ngps, nsv ! size of mesh 28 | 29 | !------------------------write element definitions 30 | DO i= 1, nlmnt 31 | WRITE(in) le(i), lt(i), nd(i), np(i) 32 | WRITE(in)(ln(j,i), j= 1, nd(i)) 33 | WRITE(in)(lg(j,i), j= 1, np(i)) 34 | END DO 35 | 36 | !----------------------write nodal variables 37 | DO i= 1, nnod 38 | i3= 3*i 39 | i2= i3 - 1 40 | i1= i2 - 1 41 | WRITE(in) ib(i) 42 | WRITE(in) x(i1), x(i2), x(i3), dx(i1), dx(i2), dx(i3) 43 | WRITE(in) fc(i1), fc(i2), fc(i3) 44 | END DO 45 | 46 | !---------------------write integration point variables 47 | DO i= 1, ngps 48 | WRITE(in) eps(i), dep(i) 49 | WRITE(in) ( sv(j,i), j= 1, nsv) 50 | WRITE(in) (dsv(j,i), j= 1, nsv) 51 | WRITE(in) (ep(j,i), j= 1, 6) 52 | WRITE(in) (de(j,i), j= 1, 6) 53 | WRITE(in) (st(j,i), j= 1, 6) 54 | WRITE(in) (ds(j,i), j= 1, 6) 55 | WRITE(in) (rt(j,i), j= 1, 3) 56 | WRITE(in) (dr(j,i), j= 1, 3) 57 | END DO 58 | 59 | !------------------------------------------write material properties 60 | WRITE(in) nmatl, nmpar 61 | DO mat_code= 1, nmatl 62 | WRITE(in) nss(mat_code) 63 | 64 | !------------------------------------write twinning limit 65 | WRITE(in) twinlim 66 | 67 | !------------------------------------write twinning probability 68 | WRITE(in) twinprob 69 | 70 | !------------------------------------write elastic constants 71 | WRITE(in) (e(j, mat_code), j= 1, 9) 72 | 73 | !------------------------------------write slip system reorientation angles 74 | WRITE(in) (ssang(j, mat_code), j= 1, nss(mat_code)) 75 | 76 | !-----------------------------------------write slip systems 77 | DO i= 1, nss(mat_code) 78 | WRITE(in) (ab(j,i,mat_code),j=1,3), & 79 | & (an(j,i,mat_code),j=1,3) 80 | END DO 81 | !---------------------------------------write ss properties 82 | DO i= 1, nss(mat_code) 83 | WRITE(in) (ampar(j,i,mat_code),j=1,nmpar) 84 | END DO 85 | 86 | !--------------------------------write latent hardening matrix 87 | DO i=1,nss(mat_code) 88 | WRITE(in) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 89 | END DO 90 | END DO 91 | !---------------------------write surface properties 92 | amu=0. 93 | anu=0. 94 | aga=0. 95 | 96 | WRITE(in) amu, anu, aga 97 | 98 | 99 | !---------------------------------write control data 100 | WRITE(in) ninc1, nxs, nfs 101 | DO i= 1, ninc1 102 | WRITE(in) tiem(i) 103 | IF ( nxs .GT. 0 ) THEN 104 | DO j= 1, nxs 105 | WRITE(in) ( x_spec(k,j,i), k= 1, 15) 106 | END DO 107 | ENDIF 108 | IF ( nfs .GT. 0 ) THEN 109 | DO j= 1, nfs 110 | WRITE(in) ( f_spec(k,j,i), k= 1, 3) 111 | END DO 112 | ENDIF 113 | END DO 114 | 115 | CLOSE(IN) 116 | 117 | END SUBROUTINE WTDATA 118 | 119 | 120 | !***********************************************************************! 121 | ! ! 122 | ! SUBROUTINE OUTFILE ! 123 | !-----------------------------------------------------------------------! 124 | ! Routine to OPEN file for writing ! 125 | ! ! 126 | !-----------------------------------------------------------------------! 127 | ! Arguments: IN INTEGER; READ channel number ! 128 | ! L_FILE LOGICAL; TRUE if file opened ok ! 129 | !-----------------------------------------------------------------------! 130 | ! ! 131 | !***********************************************************************! 132 | 133 | SUBROUTINE OUTFILE(IN,L_FILE) 134 | 135 | IMPLICIT none 136 | LOGICAL(4) :: l_file 137 | INTEGER :: in, ierr 138 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3 139 | CHARACTER(4) :: ext 140 | 141 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 142 | IF ( ierr .EQ. 0 ) THEN 143 | READ(in,*) dir1,dir2,dir3 144 | dir=dir3 145 | WRITE(*,'(''FASOLT file directory: '',\)') 146 | WRITE(*,*) dir 147 | ELSE 148 | WRITE(*,'("No dirname file found. Path is current directory.")') 149 | dir='.' 150 | END IF 151 | CLOSE(in) 152 | 153 | 154 | WRITE(*,'(''Name of FASOLT input file (no extension): '',\)') 155 | READ(*,*) f_name 156 | ext=".fsd" 157 | f_name=TRIM(dir)//TRIM(f_name)//TRIM(ext) 158 | 159 | OPEN( UNIT= IN, FILE= F_NAME, FORM= 'UNFORMATTED', & 160 | & ACCESS= 'SEQUENTIAL', STATUS= 'UNKNOWN',IOSTAT= IERR) 161 | 162 | IF ( ierr .EQ. 0 ) THEN 163 | l_file = .TRUE. 164 | ELSE 165 | WRITE(*,'("Could not open input file! ")') 166 | l_file = .FALSE. 167 | END IF 168 | 169 | END SUBROUTINE OUTFILE 170 | 171 | !***********************************************************************! 172 | ! ! 173 | ! SUBROUTINE ORIFILE ! 174 | !-----------------------------------------------------------------------! 175 | ! Routine to OPEN file for reading ORI file ! 176 | ! ! 177 | !-----------------------------------------------------------------------! 178 | ! Arguments: IN INTEGER; READ channel number ! 179 | ! L_FILE LOGICAL; TRUE if file opened ok ! 180 | !-----------------------------------------------------------------------! 181 | ! ! 182 | !***********************************************************************! 183 | 184 | SUBROUTINE ORIFILE(in,l_file) 185 | 186 | IMPLICIT none 187 | LOGICAL(4) :: l_file 188 | INTEGER :: in, ierr 189 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3 190 | CHARACTER(4) :: ext 191 | 192 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 193 | IF ( ierr .EQ. 0 ) THEN 194 | READ(in,*) dir1,dir2,dir3 195 | dir=dir2 196 | WRITE(*,'(''Orientation file directory: '',\)') 197 | WRITE(*,*) dir 198 | ELSE 199 | WRITE(*,'("No dirname file found. Path is current directory.")') 200 | dir='.' 201 | END IF 202 | CLOSE(in) 203 | 204 | 205 | WRITE (*,'(''Name of orientation data file (no extension): '',\)') 206 | ext=".ori" 207 | CALL check_file(f_name,ext,dir) 208 | 209 | OPEN( UNIT= IN, FILE= F_NAME, FORM= 'FORMATTED', & 210 | & ACCESS= 'SEQUENTIAL', STATUS= 'OLD',IOSTAT= IERR) 211 | 212 | IF ( ierr .EQ. 0 ) THEN 213 | l_file = .TRUE. 214 | ELSE 215 | WRITE(*,'("Could not open orientations file! ")') 216 | l_file = .FALSE. 217 | END IF 218 | 219 | END SUBROUTINE ORIFILE 220 | 221 | !***********************************************************************! 222 | ! ! 223 | ! SUBROUTINE MATFILE ! 224 | !-----------------------------------------------------------------------! 225 | ! Routine to OPEN file for reading material properties file ! 226 | ! ! 227 | !-----------------------------------------------------------------------! 228 | ! Arguments: IN INTEGER; READ channel number ! 229 | ! L_FILE LOGICAL; TRUE if file opened ok ! 230 | !-----------------------------------------------------------------------! 231 | ! ! 232 | !***********************************************************************! 233 | 234 | SUBROUTINE MATFILE(in,l_file) 235 | IMPLICIT none 236 | LOGICAL(4) :: l_file 237 | INTEGER :: in, ierr 238 | CHARACTER(100) :: f_name,dir,dir1,dir2,dir3 239 | CHARACTER(4) :: ext 240 | 241 | 242 | OPEN(in,FILE='dirname',STATUS='OLD', IOSTAT=ierr) 243 | IF ( ierr .EQ. 0 ) THEN 244 | READ(in,*) dir1,dir2,dir3 245 | dir=dir1 246 | WRITE(*,'(''Material data file directory: '',\)') 247 | WRITE(*,*) dir 248 | ELSE 249 | WRITE(*,'("No dirname file found. Path is current directory.")') 250 | dir='.' 251 | END IF 252 | CLOSE(in) 253 | 254 | 255 | WRITE (*,'(''Name of material data file (no extension): '',\)') 256 | ext=".fmt" 257 | 258 | CALL check_file(f_name,ext,dir) 259 | 260 | OPEN( UNIT= IN, FILE= F_NAME, FORM= 'FORMATTED', & 261 | & ACCESS= 'SEQUENTIAL', STATUS= 'OLD',IOSTAT= IERR) 262 | 263 | IF ( ierr .EQ. 0 ) THEN 264 | l_file = .TRUE. 265 | ELSE 266 | WRITE(*,'("Could not open materials file! ")') 267 | l_file = .FALSE. 268 | END IF 269 | 270 | END SUBROUTINE MATFILE 271 | 272 | !***********************************************************************! 273 | ! ! 274 | ! SUBROUTINE check_file ! 275 | !-----------------------------------------------------------------------! 276 | ! Routine to help with inputing file to open ! 277 | ! ! 278 | !-----------------------------------------------------------------------! 279 | !Arguments:f_name ext dir; to define file and path ! 280 | !here LOGICAL; TRUE if file exhists ! 281 | !-----------------------------------------------------------------------! 282 | ! ! 283 | !***********************************************************************! 284 | 285 | SUBROUTINE check_file(f_name,ext,dir) 286 | IMPLICIT none 287 | CHARACTER(100), INTENT(OUT) :: f_name 288 | CHARACTER(100), INTENT(IN) :: dir 289 | CHARACTER(4), INTENT(IN) :: ext 290 | INTEGER :: i 291 | LOGICAL :: here 292 | 293 | DO i=1,3 294 | READ(*,*) f_name 295 | f_name=TRIM(dir)//TRIM(f_name)//TRIM(ext) 296 | 297 | INQUIRE(FILE=f_name, EXIST=here) 298 | 299 | IF (here) THEN 300 | EXIT 301 | ELSE IF (i .LT. 3) THEN 302 | WRITE (*,'("File not found. Try again.")') 303 | CYCLE 304 | ELSE 305 | WRITE (*,'("File not found. Exiting.")') 306 | STOP 307 | END IF 308 | END DO 309 | 310 | END SUBROUTINE check_file 311 | -------------------------------------------------------------------------------- /src/prepro/fs3p-matl.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE SETMATC ! 4 | ! Sets the materials parameters ! 5 | ! ! 6 | ! ! 7 | !*******************************************************************************! 8 | SUBROUTINE SETMATC 9 | 10 | USE FAS_COM 11 | 12 | IMPLICIT NONE 13 | CHARACTER(LEN=1) cdum 14 | LOGICAL(4) l_file 15 | INTEGER(4) i, j, k, in, i_plas 16 | REAL(4) inislr, sumf, r, dummy, f_elas 17 | 18 | REAL(4), DIMENSION(1:maxss):: ini_ss 19 | REAL(4), DIMENSION(1:12):: frac 20 | 21 | !---------------------------------------------------no. of property sets to use 22 | WRITE(*,'(20X,''Material Property Data'',/)') 23 | WRITE(*,'(20X,''Enter number of property sets (max.12)'',\)') 24 | READ(*,*) nmatl 25 | 26 | 27 | !------------------------------------------get the number of element codes set 28 | j=0 29 | DO i= 1, nlmnt 30 | IF (le(i) .GT. j) j=le(i) 31 | END DO 32 | 33 | IF ( j .GT. nmatl ) THEN 34 | WRITE(*,'(/,15X,''There are '',I3,'' element codes! '')') j 35 | WRITE(*,'(/,15X,''Assigning at random: enter fraction for: '')') 36 | DO i= 1, nmatl 37 | WRITE(*,'(18X,''Material '',I3,'': '',\)') i 38 | READ(*,*) frac(i) 39 | END DO 40 | 41 | !------------------------------normalise and make cummulative 42 | sumf= SUM(frac(1:nmatl)) ; frac(1:nmatl)= frac(1:nmatl)/sumf 43 | IF ( nmatl.GT.1) THEN 44 | DO i=2, nmatl 45 | frac(i)= frac(i)+frac(i-1) 46 | END DO 47 | END IF 48 | 49 | DO i= 1, nlmnt 50 | CALL RANDOM_NUMBER(r) 51 | k=0 52 | DO j= 1, nmatl 53 | IF ( r .GT.frac(j) ) k=j 54 | END DO 55 | le(i)= k+1 56 | END DO 57 | END IF 58 | 59 | !---------------------------------------------get the material property data 60 | nmpar=0 61 | ampar=0. 62 | 63 | DO mat_code = 1, nmatl 64 | WRITE(*,'(25X,'' to input property set '',I3,\)'),mat_code 65 | READ(*,*) 66 | 67 | IN=51 68 | CALL MATFILE(in,l_file) 69 | 70 | READ(in,*) i_plas 71 | 72 | IF (mat_code.EQ.1) THEN 73 | nmpar= i_plas 74 | ELSE 75 | IF (i_plas.NE.nmpar) THEN 76 | WRITE(*,'(10X,''Inconsistent plastic property list!'')') 77 | PAUSE 78 | STOP 79 | END IF 80 | END IF 81 | 82 | READ(in,*) nss(mat_code) 83 | 84 | !------------------------------------read elastic constants 85 | READ(in,*) (e(i, mat_code), i= 1, 9) 86 | 87 | !------------------------------------read ss angles (also indicator of twin) 88 | READ(in,*) (ssang(i, mat_code), i= 1, nss(mat_code)) 89 | 90 | !-----------------------------------------read slip systems 91 | DO i= 1, nss(mat_code) 92 | READ(in,*) (ab(j,i,mat_code),j=1,3), & 93 | & (an(j,i,mat_code),j=1,3) 94 | END DO 95 | !---------------------------------------read ss properties 96 | DO i= 1, nss(mat_code) 97 | READ(in,*) (ampar(j,i,mat_code),j=1,nmpar) 98 | END DO 99 | 100 | !--------------------------------read latent hardening matrix 101 | DO i=1,nss(mat_code) 102 | READ(in,*) (smatrx(j,i, mat_code),j=1,nss(mat_code)) 103 | END DO 104 | CLOSE(IN) 105 | !---------------------------------------------get the initial slip resistances 106 | WRITE(*,'(5X,''Make initial slip resistances equal? (Y/N :'',\)') 107 | READ(*,*) cdum 108 | 109 | IF ( cdum.EQ.'y' .OR. cdum.EQ.'Y') THEN 110 | WRITE(*,'(5X,''Enter the initial slip resistance: '',\)') 111 | READ(*,*) inislr 112 | ini_ss(1:nss(mat_code))= inislr 113 | ELSE 114 | WRITE(*,'(5X,''Enter the '',I3, & 115 | & '' initial slip resistances:'',\)'),nss(mat_code) 116 | READ(*,*) ini_ss(1:nss(mat_code)) 117 | END IF 118 | 119 | DO i=1,nlmnt 120 | IF ( le(i) .EQ. mat_code ) THEN 121 | DO j=1,np(i) 122 | sv(4:3+nss(mat_code),lg(j,i)) = ini_ss(1:nss(mat_code)) 123 | END DO 124 | END IF 125 | END DO 126 | 127 | END DO 128 | 129 | !--------------------------------------------------option for random elastic fraction 130 | WRITE(*,'(/,2X,''Set a fraction to elastic only? (y/n): '',\)') 131 | READ(*,*) cdum 132 | IF ( cdum.EQ.'y' .OR. cdum.EQ.'Y' ) THEN 133 | WRITE(*,'(7X,''Enter elastic fraction : '',\)') 134 | READ(*,*) f_elas 135 | 136 | j=0 137 | DO i= 1, nlmnt 138 | 139 | CALL RANDOM_NUMBER(dummy) 140 | IF ( dummy .LE. f_elas ) THEN 141 | le(i) =-le(i) ; j=j+1 142 | END IF 143 | 144 | END DO 145 | 146 | WRITE(*,'(7X, G12.5,'' set elastic '')') REAL(j, 4)/ REAL(nlmnt, 4) 147 | 148 | END IF 149 | 150 | 151 | END SUBROUTINE 152 | 153 | -------------------------------------------------------------------------------- /src/prepro/fs3p-rcm.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE RENUMBER ! 4 | ! reverse Cuthill-McGee numbering optimisation ! 5 | ! ! 6 | !*******************************************************************************! 7 | SUBROUTINE RENUMBER(iprof) 8 | 9 | IMPLICIT NONE 10 | LOGICAL(4) again, swap 11 | INTEGER(4) maxlev, lsv, lcs, isv, i, j, k, lct, ibt, nm, minc, & 12 | & level, maxl, ii, iprof, lnot 13 | REAL(4) xt 14 | 15 | DIMENSION lsv(1:20000),lcs(1:20000),isv(1:20000) 16 | 17 | !----------------------------------FAFNER 3-D common blocks and declarations 18 | INTEGER(4) nlmnt, nnod, ngps, ninc, ninc0, ninc1, le, lt, nd, np, ln, lg, ib 19 | REAL(4) x, dx, fc 20 | 21 | COMMON/ numbrs/ nlmnt, nnod, ngps, ninc, ninc0, ninc1 22 | COMMON/ elnums/ le(1000), lt(1000), nd(1000), np(1000), ln(20,1000), lg(8,1000) 23 | COMMON/ glbal1/ ib(5000), x(15000), dx(15000), fc(15000) 24 | 25 | 26 | DATA maxlev/20000/ ! maximum number of levels 27 | 28 | 29 | IF ( nlmnt .LE. 1 ) RETURN ! don't even try 30 | 31 | !----------------------initialise 'number connected-to-node' list 32 | DO i= 1, nnod 33 | IF( ib(i) .EQ. 0 )THEN 34 | lcs(i)= 0 35 | ELSE 36 | lcs(i)= 1 37 | ENDIF 38 | END DO 39 | 40 | DO i= 1, nlmnt 41 | DO j= 1, nd(i) 42 | k= ln(j,i) 43 | lcs(k)= lcs(k)+1 44 | END DO 45 | END DO 46 | 47 | !------------------------get start and generate trial structure 48 | nm= 0 49 | minc= 10 50 | DO i= 1, nnod 51 | IF ( ( lcs(i) .LT. minc ) .AND. ( lcs(i) .GT. 2 ) ) THEN 52 | minc= lcs(i) 53 | nm= i 54 | ENDIF 55 | END DO 56 | 57 | CALL ROLSTRUC(.FALSE.,maxlev,nm,lsv,lcs,isv,level) 58 | maxl=level 59 | 60 | !-------------------------------search for maximum graph diameter 61 | again=.TRUE. 62 | do while (again) 63 | 64 | again=.FALSE. 65 | DO i= isv(level), isv(level-1)+1, -1 66 | ii=lsv(i) 67 | CALL ROLSTRUC(.FALSE.,maxlev,ii,lsv,lcs,isv,level) 68 | 69 | IF ( level .GT. maxl ) THEN !better one found 70 | again=.TRUE. 71 | maxl=level 72 | nm= ii 73 | ENDIF 74 | 75 | END DO 76 | 77 | END DO 78 | 79 | CALL ROLSTRUC(.TRUE.,maxlev,nm,lsv,lcs,isv,iprof) ! re-generate best structure 80 | 81 | !------------------------------- reverse-number re-order nodal sequence 82 | DO i= 1, nlmnt 83 | DO j= 1, nd(i) 84 | k= ln(j,i) 85 | ln(j,i)= lsv(k) 86 | END DO 87 | END DO 88 | 89 | again=.true. 90 | lnot= nnod + 1 91 | DO WHILE ( again) 92 | lnot=lnot-1 93 | 94 | swap=.FALSE. 95 | DO i= 2, lnot 96 | IF( lsv(i) .LT. lsv(i-1) )THEN 97 | swap=.TRUE. 98 | 99 | lct= lsv(i) 100 | lsv(i)= lsv(i-1) 101 | lsv(i-1)= lct 102 | 103 | DO j= -2,0 104 | xt= x(3*i +j) 105 | x(3*i +j)= x(3*(i-1) +j) 106 | x(3*(i-1) +j)=xt 107 | END DO 108 | 109 | ibt= ib(i) 110 | ib(i)= ib(i-1) 111 | ib(i-1)= ibt 112 | 113 | ENDIF 114 | END DO 115 | 116 | AGAIN= ( swap .AND. (lnot .GT. 2) ) 117 | END DO 118 | 119 | END SUBROUTINE 120 | 121 | !*******************************************************************************! 122 | ! ! 123 | ! SUBROUTINE ROLSTRUC ! 124 | ! Produces a rooted, ordered level structure ! 125 | ! ! 126 | !*******************************************************************************! 127 | SUBROUTINE ROLSTRUC(renum,nw,iroot,lsv,lcs,isv,iprof) 128 | 129 | IMPLICIT NONE 130 | LOGICAL(4) renum, conx 131 | INTEGER(4) nw, iroot, lsv, lcs, isv, iprof, i, i1, il, in, j, jm, jmin, & 132 | & jnn, jv, jvm, k, l, num, nums, level, lst, lfn 133 | 134 | DIMENSION lsv(1:*),lcs(1:*),isv(1:*) 135 | 136 | !----------------------------------FAFNER 3-D common blocks and declarations 137 | INTEGER(4) nlmnt, nnod, ngps, le, lt, nd, np, ln, lg, ninc, ninc0, ninc1 138 | 139 | COMMON/ numbrs/ nlmnt, nnod, ngps, ninc, ninc0, ninc1 140 | COMMON/ elnums/ le(1000), lt(1000), nd(1000), np(1000), ln(20,1000), lg(8,1000) 141 | 142 | 143 | !-----------------------------------------sort out the structure by magic 144 | DO i=1,nnod 145 | lcs(i)=-lcs(i) 146 | END DO 147 | 148 | lsv(1)= iroot 149 | lcs(iroot)= -lcs(iroot) 150 | isv(1)= 1 151 | num= 1 152 | level= 1 153 | 154 | DO WHILE ( num .LT. nnod ) 155 | 156 | IF( level .LT. 2 ) THEN 157 | lst= 1 158 | ELSE 159 | lst= isv(level-1)+1 160 | ENDIF 161 | 162 | lfn= isv(level) 163 | level= level +1 164 | 165 | DO i= lst, lfn 166 | in= lsv(i) 167 | nums= num +1 168 | 169 | DO il= 1, nlmnt 170 | conx= .FALSE. 171 | jnn= nd(il) 172 | DO j= 1, jnn 173 | IF( ln(j,il) .EQ. in ) conx=.TRUE. 174 | END DO 175 | 176 | IF ( conx ) THEN 177 | DO j=1,jnn 178 | l= ln(j,il) 179 | 180 | IF ( lcs(l) .LT. 0 ) THEN 181 | num= num +1 182 | lcs(l)= -lcs(l) 183 | k= num 184 | 185 | IF ( num .GT. nums ) THEN 186 | 187 | DO i1= num-1, nums, -1 188 | IF ( lcs(l) .LT. lcs(lsv(i1)) ) k= i1 189 | END DO 190 | 191 | IF ( k .LT. num ) THEN 192 | DO i1= num, k+1, -1 193 | lsv(i1)= lsv(i1-1) 194 | END DO 195 | ENDIF 196 | 197 | ENDIF 198 | lsv(k)=l 199 | 200 | ENDIF 201 | 202 | END DO 203 | ENDIF 204 | END DO 205 | END DO 206 | isv(level)= num 207 | 208 | END DO 209 | 210 | 211 | IF( renum ) THEN ! form re-ordering sequence and calculate profile 212 | 213 | DO i= 1, nnod 214 | j= nnod -i +1 215 | isv(lsv(i))= j 216 | END DO 217 | 218 | DO i= 1, nnod 219 | lsv(i)= isv(i) 220 | isv(i)= 1 221 | END DO 222 | 223 | DO i=1,nlmnt 224 | jm= nd(i) 225 | jmin=lsv(ln(1,i)) 226 | 227 | DO j= 2, jm 228 | jv= lsv(ln(j,i)) 229 | IF( jv .LT. jmin ) jmin= jv 230 | END DO 231 | 232 | DO j=1,jm 233 | jv= lsv(ln(j,i)) 234 | jvm= jv- jmin +1 235 | IF( jvm .GT. isv(jv) ) isv(jv)= jvm 236 | END DO 237 | END DO 238 | 239 | iprof= 0 240 | DO i= 1, nnod 241 | iprof=iprof +isv(i) 242 | END DO 243 | 244 | ELSE !just return number of levels as profile size 245 | iprof= level 246 | 247 | ENDIF 248 | 249 | END SUBROUTINE 250 | 251 | 252 | -------------------------------------------------------------------------------- /src/prepro/fs3p-swp.f90: -------------------------------------------------------------------------------- 1 | !*******************************************************************************! 2 | ! ! 3 | ! SUBROUTINE SETSWTOL ! 4 | ! Sets sweeping tolerance to alpha* minimum intra-element distance. ! 5 | ! ! 6 | !*******************************************************************************! 7 | SUBROUTINE SETSWTOL(tolerance) 8 | 9 | USE FAS_COM 10 | 11 | IMPLICIT NONE 12 | INTEGER(4) i, j, k, l 13 | REAL(4) tolerance, alpha, xlocal, lengths, del_x, lmin 14 | 15 | DIMENSION xlocal( 1:3, 1:20) 16 | 17 | DO i= 1, nlmnt ! loop on elements 18 | 19 | DO j= 1, nd(i) ! get local coordinate list 20 | DO k=1, 3 21 | xlocal(k,j)= x( 3*ln(j,i) -3 + k ) 22 | END DO 23 | END DO 24 | 25 | DO j= 1, nd(i)-1 ! calculate distances, get minimum 26 | DO k= j+1, nd(i) 27 | 28 | lengths= 0. 29 | DO l= 1, 3 30 | del_x= xlocal(l,j)- xlocal(l,k) 31 | lengths= lengths + del_x*del_x 32 | END DO 33 | 34 | IF ( ((i+j+k) .EQ. 4 ) .OR. ( lengths .LT. lmin) ) lmin= lengths 35 | 36 | END DO 37 | END DO 38 | 39 | END DO 40 | 41 | alpha= 0.5 42 | tolerance= alpha *SQRT( lmin ) !reset alpha interactively at some stage 43 | 44 | 45 | END SUBROUTINE 46 | 47 | !*******************************************************************************! 48 | ! ! 49 | ! SUBROUTINE SWEEP ! 50 | ! Eliminates common nodes (within tolerance) from mesh ! 51 | ! ! 52 | !*******************************************************************************! 53 | SUBROUTINE SWEEP( tolerance) 54 | 55 | USE FAS_COM 56 | 57 | IMPLICIT NONE 58 | LOGICAL(4) lcommon 59 | INTEGER(4) i_test, j, k, l 60 | REAL(4) tolerance, lengths, del_x 61 | 62 | 63 | i_test= 1 64 | DO WHILE( i_test .LT. nnod ) 65 | i_test= i_test + 1 66 | 67 | j=1 ! check with nodes up to less than one on trial 68 | lcommon=.FALSE. 69 | DO WHILE( (j .LT. i_test-1) .AND. (.NOT. lcommon) ) 70 | j=j+1 71 | 72 | lengths= 0. 73 | DO k= -2, 0 74 | del_x= x(3*i_test + k) - x(3*j + k) 75 | lengths= lengths + del_x*del_x 76 | END DO 77 | 78 | lcommon= SQRT(lengths) .LT. tolerance 79 | 80 | END DO 81 | 82 | 83 | IF( lcommon) THEN ! i_test is common, remove 84 | 85 | DO k= i_test, nnod-1 ! shuffle down node attributes 86 | DO l= -2, 0 87 | x(3*k +l)= x(3*(k+1) +l) 88 | dx(3*k +l)= dx(3*(k+1) +l) 89 | fc(3*k +l)= fc(3*(k+1) +l) 90 | END DO 91 | ib(k)= ib(k+1) 92 | END DO 93 | 94 | DO k= 1, nlmnt ! re-allocate topology 95 | DO l= 1, nd(k) 96 | IF ( ln(l,k) .EQ. i_test ) ln(l,k)= j 97 | IF ( ln(l,k) .GT. i_test ) ln(l,k)= ln(l,k) -1 98 | END DO 99 | END DO 100 | 101 | nnod= nnod-1 ! reduce number of nodes 102 | i_test= i_test -1 ! set marker back one 103 | 104 | END IF 105 | 106 | END DO 107 | 108 | 109 | END SUBROUTINE 110 | -------------------------------------------------------------------------------- /src/prepro/makefile: -------------------------------------------------------------------------------- 1 | objects=fas_com_mod.o fs2-xtal.o fs3p-gps.o fs3p-matl.o fs3p-swp.o fs3p-bkc.o fs3p-io_nowin.o fs3p-rcm.o fs3pre.o 2 | FC=ifort 3 | FFLAGS=-i-static -O3 4 | %.o : %.f90 5 | $(FC) -c $(FFLAGS) $< -o $@ 6 | 7 | fs3pre:$(objects) 8 | ifort $(FFLAGS) -o fs3pre $(objects) 9 | fs3pre.o:fs3pre.f90 10 | fs3p-swp.o:fs3p-swp.f90 11 | fs3p-bkc.o:fs3p-bkc.f90 12 | fs3p-gps.o:fs3p-gps.f90 13 | fs3p-matl.o:fs3p-matl.f90 14 | fs3p-io_nowin.o:fs3p-io_nowin.f90 15 | fs3p-rcm.o:fs3p-rcm.f90 16 | fs2-xtal.o:fs2-xtal.f90 17 | fas_com_mod.o:fas_com_mod.f90 18 | 19 | .PHONY:clean 20 | clean: 21 | rm fs3pre $(objects) fas_com.mod 22 | 23 | install: 24 | cp fs3pre ~/bin/ 25 | --------------------------------------------------------------------------------